on master help sign in
.buildkite/pipeline.ymlnew file+18
since splitsnapshots
unifiedsplit
@@ -0,0 +1,18 @@
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.ymldeleted−49
@@ -1,49 +0,0 @@
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.ymlnew file+39
@@ -0,0 +1,39 @@
1+name: Build binaries
2+on:
3+ release:
4+ types: [published]
5+jobs:
6+ build:
7+ strategy:
8+ fail-fast: false
9+ matrix:
10+ os: [ubuntu-latest, macOS-latest, windows-latest]
11+ runs-on: ${{ matrix.os }}
12+ steps:
13+ - uses: actions/checkout@v2
14+ - uses: actions/setup-haskell@v1
15+ if: runner.os != 'Linux'
16+ with:
17+ ghc-version: '8.10.1'
18+ cabal-version: '3.2'
19+ - name: Build Linux binary
20+ if: runner.os == 'Linux'
21+ run: |
22+ docker run \
23+ -v $(pwd):/mnt -w /mnt \
24+ utdemir/ghc-musl:v14-ghc8101 \
25+ bash .github/workflows/build.sh
26+ - name: Build ${{ runner.os }} binary
27+ if: runner.os != 'Linux'
28+ shell: bash
29+ run: |
30+ cabal build exe:ormolu
31+ cp $(find dist-newstyle \( -name ormolu -o -name ormolu.exe \) -type f) ormolu
32+ - uses: actions/upload-release-asset@v1
33+ env:
34+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
35+ with:
36+ upload_url: ${{ github.event.release.upload_url }}
37+ asset_path: ormolu
38+ asset_name: ormolu-${{ runner.os }}
39+ asset_content_type: application/octet-stream
.github/workflows/build.shnew file+7
@@ -0,0 +1,7 @@
1+set -e
2+
3+cabal update
4+cabal build exe:ormolu --enable-executable-static --ghc-options="-split-sections"
5+
6+cp $(find dist-newstyle -name ormolu -type f) .
7+strip -s ormolu
.gitignore+1
@@ -26,4 +26,5 @@ cabal.sandbox.config
26dist-*/
26dist-*/
27dist/
27dist/
28stack.yaml
28stack.yaml
29+stack.yaml.lock
29result*
30result*
CHANGELOG.md+231
@@ -1,3 +1,234 @@
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
125+ failure, but tries to format all the files. [Issue
126+ 502](https://github.com/tweag/ormolu/issues/502).
127+
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
157+
158+* Fixed rendering of record updates with the record dot preprocessor syntax
159+ [Issue 498](https://github.com/tweag/ormolu/issues/498).
160+
161+## Ormolu 0.0.3.0
162+
163+* Fixed an issue related to unnecessary use of curly braces. [Issue
164+ 473](https://github.com/tweag/ormolu/issues/473).
165+
166+* Fixed the issue with formatting multi-way if when it happens to be a
167+ function applied to arguments [Issue
168+ 488](https://github.com/tweag/ormolu/issues/488). This changed the way
169+ multi-line if is formatted in general.
170+
171+* Added support for record dot pre-processor when used via the plugin.
172+ [Issue 486](https://github.com/tweag/ormolu/issues/486).
173+
174+* Stopped hanging record constructors and improved placing
175+ potentially-hanging consturctions in the presence of comments. [Issue
176+ 447](https://github.com/tweag/ormolu/issues/447).
177+
178+* Fixed indentation in presence of type applications. [Issue
179+ 493](https://github.com/tweag/ormolu/issues/493).
180+
181+* Class and instance declarations now do not have a blank line after
182+ `where`. Grouping of methods from the original input is also preserved
183+ with some normalizations. [Issue
184+ 431](https://github.com/tweag/ormolu/issues/431).
185+
186+## Ormolu 0.0.2.0
187+
188+* Switched to `ghc-lib-parser` instead of depending on the `ghc` package
189+ directly. This should allow us to use newest features of GHC while not
190+ necessarily depending on the newest version of the compiler. In addition
191+ to that Ormolu is now GHCJS-compatible.
192+
193+* Now unrecognized GHC options passed with `--ghc-opt` cause Ormolu to fail
194+ (exit code 7).
195+
196+* Fixed formatting of result type in closed type families. See [issue
197+ 420](https://github.com/tweag/ormolu/issues/420).
198+
199+* Fixed a minor inconsistency between formatting of normal and foreign type
200+ signatures. See [issue 408](https://github.com/tweag/ormolu/issues/408).
201+
202+* Fixed a bug when comment before module header with Haddock was moved
203+ inside the export list. See [issue
204+ 430](https://github.com/tweag/ormolu/issues/430).
205+
206+* Empty `forall`s are now correctly preserved. See [issue
207+ 429](https://github.com/tweag/ormolu/issues/429).
208+
209+* Fixed [issue 446](https://github.com/tweag/ormolu/issues/446), which
210+ involved braces and operators.
211+
212+* When there are comments between preceding Haddock (pipe-style) and its
213+ corresponding declaration they are preserved like this in the output
214+ instead of being shifted. To be clear, this is not a very good idea to
215+ have comments in that position because the Haddock will end up not being
216+ associated with the declarations. Issues
217+ [440](https://github.com/tweag/ormolu/issues/440) and
218+ [448](https://github.com/tweag/ormolu/issues/448).
219+
220+* Implemented correct handling of shebangs. [Issue
221+ 377](https://github.com/tweag/ormolu/issues/377).
222+
223+* Implemented correct handling of stack headers. [Issue
224+ 393](https://github.com/tweag/ormolu/issues/393).
225+
226+* Sorting language pragmas cannot not change meaning of the input program
227+ anymore. [Issue 404](https://github.com/tweag/ormolu/issues/404).
228+
229+* Fixed formatting of applications where function is a complex expression.
230+ [Issue 444](https://github.com/tweag/ormolu/issues/444).
231+
1## Ormolu 0.0.1.0
232## Ormolu 0.0.1.0
2
233
3* Initial release.
234* Initial release.
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
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.
31 AST obtained from the original file. They should match.
32* The output of printer is checked against the expected output.
32* The output of printer is checked against the expected output.
33−* Idempotency property is verified: formatting already formatted code
33+* Idempotence property is verified: formatting already formatted code
34 results in exactly the same output.
34 results in exactly the same output.
35
35
36Examples can be organized in sub-directories, see the existing ones for
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
24
25We set for the following goals (mostly taken from
25We set for the following goals (mostly taken from
26[brittany](https://github.com/lspitzner/brittany)):
26[brittany](https://github.com/lspitzner/brittany)):
27−* Preserve the meaning of the formatted functions;
27+* Preserve the meaning of the formatted functions when no CPP is used;
28* Make reasonable use of screen space;
28* Make reasonable use of screen space;
29* Use linear space and computation time on the size of the input;
29* Use linear space and computation time on the size of the input;
30* Preserve comments;
30* Preserve comments;
@@ -140,8 +140,10 @@ impossible to guess what they'll be called on.
140
140
141### CPP
141### CPP
142
142
143−Formatting a module which uses CPP directives won't be supported. Instead,
143+We allow CPP directives in the input, but we forgo the goal to preserve the
144+meaning of the formatted functions in that case.
145+Instead of supporting CPP better, we hope for a solution to replace CPP to
144−we hope for a solution to replace CPP to do conditional compilation.
146+do conditional compilation.
145
147
146There are the following challenges when formatting a module with CPP:
148There are the following challenges when formatting a module with CPP:
147
149
@@ -180,14 +182,15 @@ True
180```
182```
181
183
182At the time of this writing, formatting this program with Hindent
184At the time of this writing, formatting this program with Hindent
183−produces the same output we would get if the CPP directives were
185+or Ormolu produces the same output we would get if the CPP directives
184−considered comments:
186+were considered comments:
185
187
186```
188```
187−$ hindent --version
189+$ ormolu --version
188−hindent 5.2.7
190+ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115
191+using ghc-lib-parser 8.10.1.20200412
189
192
190−$ hindent test.hs
193+$ ormolu --mode inplace test.hs
191
194
192$ cat test.hs
195$ cat test.hs
193{-# LANGUAGE CPP #-}
196{-# LANGUAGE CPP #-}
@@ -227,9 +230,6 @@ to parse Haskell modules. If CPP is replaced with some language
227extension or mechanism to do conditional compilation, all tools
230extension or mechanism to do conditional compilation, all tools
228will benefit from it.
231will benefit from it.
229
232
230−Therefore, CPP won't be supported. If the CPP extension
231−is enabled, we should signal an error right away.
232−
233### Printing
233### Printing
234
234
235Just pretty-printing code (following the approach of Hindent) seems sane. It
235Just pretty-printing code (following the approach of Hindent) seems sane. It
README.md+62−14
@@ -4,7 +4,7 @@
4[![Hackage](https://img.shields.io/hackage/v/ormolu.svg?style=flat)](https://hackage.haskell.org/package/ormolu)
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)
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)
6[![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/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)
7+[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu)
8
8
9Ormolu is a formatter for Haskell source code. The project was created with
9Ormolu is a formatter for Haskell source code. The project was created with
10the following goals in mind:
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
22* That formatting style aims to result in minimal diffs while still
23 remaining very close to “conventional” Haskell formatting people use.
23 remaining very close to “conventional” Haskell formatting people use.
24* Choose a style compatible with modern dialects of Haskell. As new Haskell
24* Choose a style compatible with modern dialects of Haskell. As new Haskell
25− extensions enter broad use, we may change the style to accomodate them.
25+ extensions enter broad use, we may change the style to accommodate them.
26* Idempotence: formatting already formatted code doesn't change it.
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
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.
28 projects without exposing unfortunate, disappointing bugs here and there.
@@ -45,11 +45,12 @@ Alternatively, `stack` could be used with a `stack.yaml` file as follows.
45
45
46```console
46```console
47$ cat stack.yaml
47$ cat stack.yaml
48−resolver: lts-14.3
48+resolver: lts-16.0
49packages:
49packages:
50- '.'
50- '.'
51
51
52−$ stack build
52+$ stack build # to build
53+$ stack install # to install
53```
54```
54
55
55To use Ormolu directly from GitHub with Nix, this snippet may come in handy:
56To use Ormolu directly from GitHub with Nix, this snippet may come in handy:
@@ -91,19 +92,44 @@ formatted output.
91$ ormolu --mode inplace Module.hs
92$ ormolu --mode inplace Module.hs
92```
93```
93
94
95+Use `find` to format a tree recursively:
96+
97+```console
98+$ ormolu --mode inplace $(find . -name '*.hs')
99+```
100+
101+## Magic comments
102+
103+Ormolu understands two magic comments:
104+
105+```haskell
106+{- ORMOLU_DISABLE -}
107+```
108+
109+and
110+
111+```haskell
112+{- ORMOLU_ENABLE -}
113+```
114+
115+This allows us to disable formatting selectively for code between these
116+markers or disable it for the entire file. To achieve the latter, just put
117+`{- ORMOLU_DISABLE -}` at the very top. Note that the source code should
118+still be parseable even without the “excluded” part. Because of that the
119+magic comments cannot be placed arbitrary, but should rather enclose
120+independent top-level definitions.
121+
94## Current limitations
122## Current limitations
95
123
96−* Does not handle CPP (wontfix, see [the design document][design]).
124+* CPP support is experimental. CPP is virtually impossible to handle
125+ correctly, so we process them as a sort of unchangeable snippets. This
126+ works only in simple cases when CPP conditionals surround top-level
127+ declarations. See the [CPP][design-cpp] section in the design notes for
128+ a discussion of the dangers.
97* Input modules should be parsable by Haddock, which is a bit stricter
129* Input modules should be parsable by Haddock, which is a bit stricter
98 criterion than just being valid Haskell modules.
130 criterion than just being valid Haskell modules.
99* Various minor idempotence issues, most of them are related to comments.
131* Various minor idempotence issues, most of them are related to comments.
100
132
101−## Editor integration
102−
103−We know of the following editor integrations:
104−
105−* [For Emacs][emacs-package]
106−
107## Running on Hackage
133## Running on Hackage
108
134
109It's possible to try Ormolu on arbitrary packages from Hackage. For that
135It's possible to try Ormolu on arbitrary packages from Hackage. For that
@@ -118,16 +144,38 @@ also contain formatted `.hs` files for inspection and original inputs with
118`.hs-original` extension (those are with CPP dropped, exactly what is fed
144`.hs-original` extension (those are with CPP dropped, exactly what is fed
119into Ormolu).
145into Ormolu).
120
146
147+## Editor integration
148+
149+We know of the following editor integrations:
150+
151+* [Emacs][emacs-package]
152+* [VS Code][vs-code-plugin]
153+* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu]
154+
155+## Arch Linux
156+
157+To install Ormolu on Arch Linux, one can use [the package on AUR][aur]:
158+
159+```console
160+yay -S ormolu
161+```
162+
121## Contributing
163## Contributing
122
164
123−See [CONTRIBUTING.md](./CONTRIBUTING.md).
165+See [CONTRIBUTING.md][contributing].
124
166
125## License
167## License
126
168
127−See [LICENSE.md](./LICENSE.md).
169+See [LICENSE.md][license].
128
170
129Copyright © 2018–present Tweag I/O
171Copyright © 2018–present Tweag I/O
130
172
131−[design]: ./DESIGN.md#cpp
173+[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
174+[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md
175+[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md
132[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
176[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
133[emacs-package]: https://github.com/vyorkin/ormolu.el
177[emacs-package]: https://github.com/vyorkin/ormolu.el
178+[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+133−95
@@ -1,12 +1,17 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeApplications #-}
5
6
6module Main (main) where
7module Main (main) where
7
8
9+import Control.Exception (SomeException, displayException, try)
8import Control.Monad
10import Control.Monad
11+import Data.Bool (bool)
12+import Data.Either (lefts)
9import Data.List (intercalate, sort)
13import Data.List (intercalate, sort)
14+import qualified Data.Text.IO as TIO
10import Data.Version (showVersion)
15import Data.Version (showVersion)
11import Development.GitRev
16import Development.GitRev
12import Options.Applicative
17import Options.Applicative
@@ -16,10 +21,8 @@ import Ormolu.Utils (showOutputable)
16import Paths_ormolu (version)
21import Paths_ormolu (version)
17import System.Exit (ExitCode (..), exitWith)
22import System.Exit (ExitCode (..), exitWith)
18import System.IO (hPutStrLn, stderr)
23import System.IO (hPutStrLn, stderr)
19−import qualified Data.Text.IO as TIO
20
24
21-- | Entry point of the program.
25-- | Entry point of the program.
22−
23main :: IO ()
26main :: IO ()
24main = withPrettyOrmoluExceptions $ do
27main = withPrettyOrmoluExceptions $ do
25 Opts {..} <- execParser optsParserInfo
28 Opts {..} <- execParser optsParserInfo
@@ -27,35 +30,50 @@ main = withPrettyOrmoluExceptions $ do
27 case optInputFiles of
30 case optInputFiles of
28 [] -> formatOne' Nothing
31 [] -> formatOne' Nothing
29 ["-"] -> formatOne' Nothing
32 ["-"] -> formatOne' Nothing
30− xs -> mapM_ (formatOne' . Just) xs
33+ [x] -> formatOne' (Just x)
34+ xs -> do
35+ -- It is possible to get IOException, error's and 'OrmoluException's
36+ -- from 'formatOne', so we just catch everything.
37+ errs <-
38+ lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)
39+ unless (null errs) $ do
40+ mapM_ (hPutStrLn stderr . displayException) errs
41+ exitWith (ExitFailure 102)
31
42
32-- | Format a single input.
43-- | Format a single input.
33−
34−formatOne
44+formatOne ::
35− :: Mode -- ^ Mode of operation
45+ -- | Mode of operation
46+ Mode ->
36− -> Config -- ^ Configuration
47+ -- | Configuration
48+ Config RegionIndices ->
37− -> Maybe FilePath -- ^ File to format or stdin as 'Nothing'
49+ -- | File to format or stdin as 'Nothing'
50+ Maybe FilePath ->
38− -> IO ()
51+ IO ()
39formatOne mode config = \case
52formatOne mode config = \case
40 Nothing -> do
53 Nothing -> do
41 r <- ormoluStdin config
54 r <- ormoluStdin config
42 case mode of
55 case mode of
43 Stdout -> TIO.putStr r
56 Stdout -> TIO.putStr r
44− _ -> do
57+ _ -> do
45− hPutStrLn stderr
58+ hPutStrLn
59+ stderr
46 "This feature is not supported when input comes from stdin."
60 "This feature is not supported when input comes from stdin."
47− -- 101 is different from all the other exit codes we already use.
61+ -- 101 is different from all the other exit codes we already use.
48 exitWith (ExitFailure 101)
62 exitWith (ExitFailure 101)
49 Just inputFile -> do
63 Just inputFile -> do
64+ originalInput <- TIO.readFile inputFile
50− r <- ormoluFile config inputFile
65+ formattedInput <- ormoluFile config inputFile
51 case mode of
66 case mode of
52 Stdout ->
67 Stdout ->
53− TIO.putStr r
68+ TIO.putStr formattedInput
54− InPlace ->
69+ InPlace -> do
70+ -- Only write when the contents have changed, in order to avoid
71+ -- updating the modified timestamp if the file was already correctly
72+ -- formatted.
73+ when (formattedInput /= originalInput) $
55− TIO.writeFile inputFile r
74+ TIO.writeFile inputFile formattedInput
56 Check -> do
75 Check -> do
57− r' <- TIO.readFile inputFile
76+ when (formattedInput /= originalInput) $
58− when (r /= r') $
59 -- 100 is different to all the other exit code that are emitted
77 -- 100 is different to all the other exit code that are emitted
60 -- either from an 'OrmoluException' or from 'error' and
78 -- either from an 'OrmoluException' or from 'error' and
61 -- 'notImplemented'.
79 -- 'notImplemented'.
@@ -65,101 +83,121 @@ formatOne mode config = \case
65-- Command line options parsing.
83-- Command line options parsing.
66
84
67data Opts = Opts
85data Opts = Opts
68− { optMode :: !Mode
69− -- ^ Mode of operation
86+ { -- | Mode of operation
87+ optMode :: !Mode,
88+ -- | Ormolu 'Config'
70− , optConfig :: !Config
89+ optConfig :: !(Config RegionIndices),
71− -- ^ Ormolu 'Config'
72− , optInputFiles :: ![FilePath]
73− -- ^ 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]
74 }
92 }
75
93
76-- | Mode of operation.
94-- | Mode of operation.
77−
78data Mode
95data Mode
79− = Stdout -- ^ Output formatted source code to stdout
96+ = -- | Output formatted source code to stdout
97+ Stdout
80− | InPlace -- ^ Overwrite original file
98+ | -- | Overwrite original file
99+ InPlace
81− | Check -- ^ Exit with non-zero status code if
100+ | -- | Exit with non-zero status code if
82− -- source is not already formatted
101+ -- source is not already formatted
102+ Check
83 deriving (Eq, Show)
103 deriving (Eq, Show)
84
104
85optsParserInfo :: ParserInfo Opts
105optsParserInfo :: ParserInfo Opts
106+optsParserInfo =
86−optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $
107+ info (helper <*> ver <*> exts <*> optsParser) . mconcat $
87− [ fullDesc
108+ [ fullDesc,
88− , progDesc ""
109+ progDesc "",
89− , header ""
110+ header ""
90− ]
111+ ]
91 where
112 where
92 ver :: Parser (a -> a)
113 ver :: Parser (a -> a)
114+ ver =
93− ver = infoOption verStr . mconcat $
115+ infoOption verStr . mconcat $
94− [ long "version"
116+ [ long "version",
95− , short 'v'
117+ short 'v',
96− , help "Print version of the program"
118+ help "Print version of the program"
97− ]
119+ ]
120+ verStr =
98− verStr = intercalate "\n"
121+ intercalate
122+ "\n"
99− [ unwords
123+ [ unwords
100− [ "ormolu"
124+ [ "ormolu",
101− , showVersion version
125+ showVersion version,
102− , $gitBranch
126+ $gitBranch,
103− , $gitHash
127+ $gitHash
128+ ],
129+ "using ghc-lib-parser " ++ VERSION_ghc_lib_parser
104 ]
130 ]
105− , "using ghc " ++ VERSION_ghc
106− ]
107 exts :: Parser (a -> a)
131 exts :: Parser (a -> a)
132+ exts =
108− exts = infoOption displayExts . mconcat $
133+ infoOption displayExts . mconcat $
109− [ long "manual-exts"
134+ [ long "manual-exts",
110− , help "Display extensions that need to be enabled manually"
135+ help "Display extensions that need to be enabled manually"
111− ]
136+ ]
112 displayExts = unlines $ sort (showOutputable <$> manualExts)
137 displayExts = unlines $ sort (showOutputable <$> manualExts)
113
138
114optsParser :: Parser Opts
139optsParser :: Parser Opts
115−optsParser = Opts
140+optsParser =
141+ Opts
142+ <$> ( (fmap (bool Stdout InPlace) . switch . mconcat)
143+ [ short 'i',
144+ help "A shortcut for --mode inplace"
145+ ]
116− <$> (option parseMode . mconcat)
146+ <|> (option parseMode . mconcat)
117− [ long "mode"
147+ [ long "mode",
118− , short 'm'
148+ short 'm',
119− , metavar "MODE"
149+ metavar "MODE",
120− , value Stdout
150+ value Stdout,
121− , help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"
151+ help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"
122− ]
152+ ]
153+ )
123− <*> configParser
154+ <*> configParser
124− <*> (many . strArgument . mconcat)
155+ <*> (many . strArgument . mconcat)
125− [ metavar "FILE"
156+ [ metavar "FILE",
126− , help "Haskell source files to format or stdin (default)"
157+ help "Haskell source files to format or stdin (default)"
127− ]
158+ ]
128
159
129−configParser :: Parser Config
160+configParser :: Parser (Config RegionIndices)
130−configParser = Config
161+configParser =
162+ Config
131− <$> (fmap (fmap DynOption) . many . strOption . mconcat)
163+ <$> (fmap (fmap DynOption) . many . strOption . mconcat)
132− [ long "ghc-opt"
164+ [ long "ghc-opt",
133− , short 'o'
165+ short 'o',
134− , metavar "OPT"
166+ metavar "OPT",
135− , help "GHC options to enable (e.g. language extensions)"
167+ help "GHC options to enable (e.g. language extensions)"
136− ]
168+ ]
137− <*> (switch . mconcat)
169+ <*> (switch . mconcat)
138− [ long "unsafe"
170+ [ long "unsafe",
139− , short 'u'
171+ short 'u',
140− , help "Do formatting faster but without automatic detection of defects"
172+ help "Do formatting faster but without automatic detection of defects"
141− ]
173+ ]
142− <*> (switch . mconcat)
174+ <*> (switch . mconcat)
143− [ long "debug"
175+ [ long "debug",
144− , short 'd'
176+ short 'd',
145− , help "Output information useful for debugging"
177+ help "Output information useful for debugging"
146− ]
178+ ]
147− <*> (switch . mconcat)
148− [ long "tolerate-cpp"
149− , short 'p'
150− , help "Do not fail if CPP pragma is present"
151− ]
152− <*> (switch . mconcat)
179+ <*> (switch . mconcat)
153− [ long "check-idempotency"
180+ [ long "check-idempotence",
154− , short 'c'
181+ short 'c',
155− , help "Fail if formatting is not idempotent"
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)"
156− ]
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+ )
157
196
158----------------------------------------------------------------------------
197----------------------------------------------------------------------------
159-- Helpers
198-- Helpers
160
199
161-- | Parse 'Mode'.
200-- | Parse 'Mode'.
162−
163parseMode :: ReadM Mode
201parseMode :: ReadM Mode
164parseMode = eitherReader $ \case
202parseMode = eitherReader $ \case
165 "stdout" -> Right Stdout
203 "stdout" -> Right Stdout
data/examples/declaration/annotation/annotation-out.hs+1
@@ -18,4 +18,5 @@ foo = 5
18
18
19data Foo = Foo Int
19data Foo = Foo Int
20{-# ANN type Foo ("HLint: ignore") #-}
20{-# ANN type Foo ("HLint: ignore") #-}
21+
21{- Comment -}
22{- Comment -}
data/examples/declaration/class/associated-data1-out.hs−1
@@ -4,7 +4,6 @@ class Foo a where data FooBar a
4
4
5-- | Something.
5-- | Something.
6class Bar a where
6class Bar a where
7−
8 -- | Bar bar
7 -- | Bar bar
9 data BarBar a
8 data BarBar a
10
9
data/examples/declaration/class/associated-data2-out.hs−1
@@ -4,7 +4,6 @@ module Main where
4
4
5-- | Something more.
5-- | Something more.
6class Baz a where
6class Baz a where
7−
8 -- | Baz bar
7 -- | Baz bar
9 data
8 data
10 BazBar
9 BazBar
data/examples/declaration/class/associated-type-defaults-out.hs−2
@@ -4,7 +4,6 @@ class Foo a where type FooBar a = Int
4
4
5-- | Something.
5-- | Something.
6class Bar a where
6class Bar a where
7−
8 -- Define bar
7 -- Define bar
9 type
8 type
10 BarBar a =
9 BarBar a =
@@ -18,7 +17,6 @@ class Bar a where
18 a
17 a
19
18
20class Baz a where
19class Baz a where
21−
22 type
20 type
23 BazBar
21 BazBar
24 a
22 a
data/examples/declaration/class/associated-types1-out.hs−1
@@ -4,7 +4,6 @@ class Foo a where type FooBar a
4
4
5-- | Something.
5-- | Something.
6class Bar a where
6class Bar a where
7−
8 -- | Bar bar
7 -- | Bar bar
9 type BarBar a
8 type BarBar a
10
9
data/examples/declaration/class/associated-types2-out.hs−1
@@ -4,7 +4,6 @@ module Main where
4
4
5-- | Something more.
5-- | Something more.
6class Baz a where
6class Baz a where
7−
8 -- | Baz bar
7 -- | Baz bar
9 type
8 type
10 BazBar
9 BazBar
data/examples/declaration/class/default-implementations-comments-out.hs−1
@@ -2,7 +2,6 @@ module Main where
2
2
3-- | Baz
3-- | Baz
4class Baz a where
4class Baz a where
5−
6 foobar :: a -> a
5 foobar :: a -> a
7 foobar a =
6 foobar a =
8 barbaz (bazbar a)
7 barbaz (bazbar a)
data/examples/declaration/class/default-signatures-out.hs−2
@@ -4,13 +4,11 @@ module Main where
4
4
5-- | Something else.
5-- | Something else.
6class Bar a where
6class Bar a where
7−
8 -- | Bar
7 -- | Bar
9 bar ::
8 bar ::
10 String ->
9 String ->
11 String ->
10 String ->
12 a
11 a
13−
14 -- Pointless comment
12 -- Pointless comment
15 default bar ::
13 default bar ::
16 ( Read a,
14 ( Read a,
data/examples/declaration/class/default-signatures-simple-out.hs−2
@@ -2,9 +2,7 @@ module Main where
2
2
3-- | Something.
3-- | Something.
4class Foo a where
4class Foo a where
5−
6 -- | Foo
5 -- | Foo
7 foo :: a -> String
6 foo :: a -> String
8−
9 default foo :: Show a => a -> String
7 default foo :: Show a => a -> String
10 foo = show
8 foo = show
data/examples/declaration/class/dependency-super-classes-out.hs+2−4
@@ -4,9 +4,7 @@ module Main where
4
4
5-- | Something.
5-- | Something.
6class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where
6class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where
7−
8 get :: m s
7 get :: m s
9−
10 put :: s -> m ()
8 put :: s -> m ()
11
9
12-- | 'MonadParsec'
10-- | 'MonadParsec'
@@ -15,8 +13,8 @@ class
15 MonadPlus m -- Potential for failure
13 MonadPlus m -- Potential for failure
16 ) =>
14 ) =>
17 MonadParsec e s m
15 MonadParsec e s m
18− | m -> e s where
16+ | m -> e s
19−
17+ where
20 -- | 'getState' returns state
18 -- | 'getState' returns state
21 getState ::
19 getState ::
22 m s
20 m s
data/examples/declaration/class/functional-dependencies-out.hs+2−1
@@ -14,5 +14,6 @@ class
14 b c -> a d, -- Bar
14 b c -> a d, -- Bar
15 a c -> b d, -- Baz
15 a c -> b d, -- Baz
16 a c d -> b,
16 a c d -> b,
17− a b d -> a b c d where
17+ a b d -> a b c d
18+ where
18 baz :: a -> b
19 baz :: a -> b
data/examples/declaration/class/multi-parameters2-out.hs+2−3
@@ -10,11 +10,10 @@ class
10 c -- Baz bar
10 c -- Baz bar
11 d -- Baz baz
11 d -- Baz baz
12 e -- Rest
12 e -- Rest
13+ f
13− f where
14+ where
14−
15 barbaz ::
15 barbaz ::
16 a -> f
16 a -> f
17−
18 bazbar ::
17 bazbar ::
19 e ->
18 e ->
20 f
19 f
data/examples/declaration/class/newlines-after-where-out.hsnew file+5
@@ -0,0 +1,5 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+
4+class Num a where
5+ (+) :: a -> a -> a
data/examples/declaration/class/newlines-after-where.hsnew file+7
@@ -0,0 +1,7 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+
4+class Num a where
5+
6+
7+ (+) :: a -> a -> a
data/examples/declaration/class/newlines-and-default-decls-out.hsnew file+11
@@ -0,0 +1,11 @@
1+class Foo a where
2+ foo :: a
3+ default foo :: ()
4+ foo = ()
5+ bar :: a
6+ default bar :: ()
7+ bar = ()
8+
9+ qux :: a
10+ default qux :: ()
11+ qux = ()
data/examples/declaration/class/newlines-and-default-decls.hsnew file+13
@@ -0,0 +1,13 @@
1+class Foo a where
2+ foo :: a
3+ default foo :: ()
4+ foo = ()
5+ bar :: a
6+ default bar :: ()
7+ bar = ()
8+
9+ qux :: a
10+
11+ default qux :: ()
12+
13+ qux = ()
data/examples/declaration/class/newlines-and-haddocks-out.hsnew file+23
@@ -0,0 +1,23 @@
1+class Foo a where
2+ -- | Haddock
3+ foo :: a
4+
5+ -- | Another Haddock
6+ bar :: a
7+
8+ baz :: a
9+ -- ^ Post-Haddock
10+
11+ raz :: a
12+ -- ^ Another Post-Haddock
13+
14+ -- | One more Haddock
15+ qux :: a
16+
17+ -- Comment before a Haddock
18+
19+ -- | And one more Haddock
20+ xyz :: a
21+
22+ -- | Haddock followed by a blank line
23+ abc :: a
data/examples/declaration/class/newlines-and-haddocks.hsnew file+19
@@ -0,0 +1,19 @@
1+class Foo a where
2+ -- | Haddock
3+ foo :: a
4+ -- | Another Haddock
5+ bar :: a
6+ baz :: a
7+ -- ^ Post-Haddock
8+ raz :: a
9+ -- ^ Another Post-Haddock
10+
11+ -- | One more Haddock
12+ qux :: a
13+ -- Comment before a Haddock
14+ -- | And one more Haddock
15+ xyz :: a
16+
17+ -- | Haddock followed by a blank line
18+
19+ abc :: a
data/examples/declaration/class/newlines-between-methods-out.hsnew file+17
@@ -0,0 +1,17 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+ (-) :: a -> a -> a
4+ (*) :: a -> a -> a
5+
6+ -- Comment before definition
7+ negate :: a -> a
8+
9+ -- Comment after definition
10+
11+ -- Separator
12+
13+ abs :: a -> a
14+ signum :: a -> a
15+
16+ -- Comment between unrelated definitions
17+ fromInteger :: Integer -> a
data/examples/declaration/class/newlines-between-methods.hsnew file+15
@@ -0,0 +1,15 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+ (-) :: a -> a -> a
4+ (*) :: a -> a -> a
5+
6+ -- Comment before definition
7+ negate :: a -> a
8+ -- Comment after definition
9+
10+ -- Separator
11+
12+ abs :: a -> a
13+ signum :: a -> a
14+ -- Comment between unrelated definitions
15+ fromInteger :: Integer -> a
data/examples/declaration/class/single-parameters-out.hs−2
@@ -21,8 +21,6 @@ class Baz a where
21 a
21 a
22
22
23class BarBaz a where
23class BarBaz a where
24−
25 barbaz ::
24 barbaz ::
26 a -> b
25 a -> b
27−
28 bazbar :: b -> a
26 bazbar :: b -> a
data/examples/declaration/class/type-operators3-out.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE PolyKinds #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE NoStarIsType #-}
5+
6+class PNum x where
7+ type (a :: x) * (b :: x)
8+
9+instance PNum Nat where
10+ type a * b = ()
data/examples/declaration/class/type-operators3.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# LANGUAGE TypeFamilies, TypeOperators, NoStarIsType, PolyKinds #-}
2+
3+class PNum x where
4+ type (a :: x) * (b :: x)
5+
6+instance PNum Nat where
7+ type a * b = ()
data/examples/declaration/data/existential-multiline-out.hs+12
@@ -3,3 +3,15 @@
3data Foo
3data Foo
4 = forall a. MkFoo a (a -> Bool)
4 = forall a. MkFoo a (a -> Bool)
5 | forall a. Eq a => MkBar a
5 | forall a. Eq a => MkBar a
6+
7+data Bar
8+ = forall x y.
9+ Bar x y x y
10+
11+data Baz
12+ = forall x y.
13+ Baz
14+ x
15+ y
16+ x
17+ y
data/examples/declaration/data/existential-multiline.hs+7
@@ -3,3 +3,10 @@
3data Foo
3data Foo
4 = forall a. MkFoo a (a -> Bool)
4 = forall a. MkFoo a (a -> Bool)
5 | forall a. Eq a => MkBar a
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/existential-out.hs+2
@@ -1,3 +1,5 @@
1{-# LANGUAGE ExistentialQuantification #-}
1{-# LANGUAGE ExistentialQuantification #-}
2
2
3data Foo = forall a. MkFoo a (a -> Bool)
3data Foo = forall a. MkFoo a (a -> Bool)
4+
5+data Bar = forall a b. a + b => Bar a b
data/examples/declaration/data/existential.hs+2
@@ -1,3 +1,5 @@
1{-# LANGUAGE ExistentialQuantification #-}
1{-# LANGUAGE ExistentialQuantification #-}
2
2
3data Foo = forall a. MkFoo a (a -> Bool)
3data Foo = forall a. MkFoo a (a -> Bool)
4+
5+data Bar = forall a b. a + b => Bar a b
data/examples/declaration/data/field-layout/gadt-out.hs+2−1
@@ -6,5 +6,6 @@ data Foo a b where
6 Foo :: Foo Int Int
6 Foo :: Foo Int Int
7 -- | Something else
7 -- | Something else
8 Bar ::
8 Bar ::
9+ Foo
9− Foo Char
10+ Char
10 Char
11 Char
data/examples/declaration/data/field-layout/record-out.hs+9−9
@@ -1,12 +1,12 @@
1module Main where
1module Main where
2
2
3-- | Foo.
3-- | Foo.
4−data Foo
4+data Foo = Foo
5− = Foo
6− { -- | Something
5+ { -- | Something
7− foo :: Foo Int Int,
6+ foo :: Foo Int Int,
8− -- | Something else
7+ -- | Something else
9− bar ::
8+ bar ::
9+ Bar
10− Bar Char
10+ Char
11− Char
11+ Char
12− }
12+ }
data/examples/declaration/data/gadt/multiline-out.hs+1−1
@@ -8,7 +8,7 @@ data Foo a where
8 Foo ::
8 Foo ::
9 forall a b.
9 forall a b.
10 (Show a, Eq b) => -- foo
10 (Show a, Eq b) => -- foo
11− -- bar
11+ -- bar
12 a ->
12 a ->
13 b ->
13 b ->
14 Foo 'Int
14 Foo 'Int
data/examples/declaration/data/gadt/multiline-where-out.hsnew file+7
@@ -0,0 +1,7 @@
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.hsnew file+6
@@ -0,0 +1,6 @@
1+data
2+ Foo
3+ a
4+ b
5+ c where
6+ Foo :: a -> b -> c -> Foo a b c
data/examples/declaration/data/gadt/strictness-out.hs+2−1
@@ -1,2 +1,3 @@
1data Foo a where
1data Foo a where
2− Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
2+ Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
3+ Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int
data/examples/declaration/data/gadt/strictness.hs+2−1
@@ -1,2 +1,3 @@
1data Foo a where
1data Foo a where
2− Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
2+ Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
3+ Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int
data/examples/declaration/data/kind-annotations-out.hs+8
@@ -1,3 +1,11 @@
1data Something (n :: Nat) = Something
1data Something (n :: Nat) = Something
2
2
3data Format (k :: *) (k' :: *) (k'' :: *)
3data Format (k :: *) (k' :: *) (k'' :: *)
4+
5+type Parens1 = Proxy '(a :: A, b :: (B :: *))
6+
7+type Parens2 = Proxy '((a :: A), (b :: B))
8+
9+type family Foo a where
10+ Foo '(a :: Int, b :: Bool) = Int
11+ Foo '((a :: Int), (b :: Bool)) = Int
data/examples/declaration/data/kind-annotations.hs+7
@@ -1,3 +1,10 @@
1data Something (n :: Nat) = Something
1data Something (n :: Nat) = Something
2
2
3data Format (k :: *) (k' :: *) (k'' :: *)
3data Format (k :: *) (k' :: *) (k'' :: *)
4+
5+type Parens1 = Proxy '(a :: A, b :: (B :: *))
6+type Parens2 = Proxy '((a :: A), (b :: B))
7+
8+type family Foo a where
9+ Foo '(a :: Int, b :: Bool) = Int
10+ Foo '((a :: Int), (b :: Bool)) = Int
data/examples/declaration/data/multiline-arg-parens-out.hs+1−1
@@ -5,6 +5,6 @@ data Foo
5 = Foo
5 = Foo
6 Bar
6 Bar
7 (Set Baz) -- and here we go
7 (Set Baz) -- and here we go
8− -- and that's it
8+ -- and that's it
9 Text
9 Text
10 deriving (Eq)
10 deriving (Eq)
data/examples/declaration/data/operators-out.hsnew file+12
@@ -0,0 +1,12 @@
1+data ErrorMessage' s
2+ = -- | Show the text as is.
3+ Text s
4+ | -- | Pretty print the type.
5+ -- @ShowType :: k -> ErrorMessage@
6+ forall t. ShowType t
7+ | -- | Put two pieces of error message next
8+ -- to each other.
9+ ErrorMessage' s :<>: ErrorMessage' s
10+ | -- | Stack two pieces of error message on top
11+ -- of each other.
12+ ErrorMessage' s :$$: ErrorMessage' s
data/examples/declaration/data/operators.hsnew file+12
@@ -0,0 +1,12 @@
1+data ErrorMessage' s
2+ = -- | Show the text as is.
3+ Text s
4+ | -- | Pretty print the type.
5+ -- @ShowType :: k -> ErrorMessage@
6+ forall t. ShowType t
7+ | -- | Put two pieces of error message next
8+ -- to each other.
9+ ErrorMessage' s :<>: ErrorMessage' s
10+ | -- | Stack two pieces of error message on top
11+ -- of each other.
12+ ErrorMessage' s :$$: ErrorMessage' s
data/examples/declaration/data/partly-documented-out.hsnew file+5
@@ -0,0 +1,5 @@
1+data Optimisation
2+ = PETransform
3+ | -- | partial eval and associated transforms
4+ GeneralisedNatHack
5+ deriving (Show, Eq, Generic)
data/examples/declaration/data/partly-documented.hsnew file+2
@@ -0,0 +1,2 @@
1+data Optimisation = PETransform | GeneralisedNatHack -- ^ partial eval and associated transforms
2+ deriving (Show, Eq, Generic)
data/examples/declaration/data/record-multi-const-out.hsnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+-- | Something.
4+data Foo
5+ = Foo
6+ { -- | X
7+ fooX :: Int,
8+ -- | Y
9+ fooY :: Int
10+ }
11+ | Bar
12+ { -- | X
13+ barX :: Int,
14+ -- | Y
15+ barY :: Int
16+ }
17+ deriving (Eq, Show)
data/examples/declaration/data/record-multi-const.hsnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+-- | Something.
4+
5+data Foo = Foo
6+ { fooX :: Int -- ^ X
7+ , fooY :: Int -- ^ Y
8+ } |
9+ Bar
10+ { barX :: Int -- ^ X
11+ , barY :: Int -- ^ Y
12+ }
13+ deriving (Eq, Show)
data/examples/declaration/data/record-out.hs+19−20
@@ -1,24 +1,23 @@
1module Main where
1module Main where
2
2
3-- | Something.
3-- | Something.
4−data Foo
4+data Foo = Foo
5− = Foo
6− { -- | X
5+ { -- | X
7− fooX :: Int,
6+ fooX :: Int,
8− -- | Y
7+ -- | Y
9− fooY :: Int,
8+ fooY :: Int,
10− -- | BarBaz
9+ -- | BarBaz
11− fooBar, fooBaz :: NonEmpty (Identity Bool),
10+ fooBar, fooBaz :: NonEmpty (Identity Bool),
12− -- | GagGog
11+ -- | GagGog
13− fooGag,
12+ fooGag,
14− fooGog ::
13+ fooGog ::
15− NonEmpty
14+ NonEmpty
16− ( Indentity
15+ ( Indentity
17− Bool
16+ Bool
18− ),
17+ ),
19− -- | Huh!
18+ -- | Huh!
20− fooFoo,
19+ fooFoo,
21− barBar ::
20+ barBar ::
22− Int
21+ Int
23− }
22+ }
24 deriving (Eq, Show)
23 deriving (Eq, Show)
data/examples/declaration/data/simple-broken-out.hs+1−2
@@ -1,8 +1,7 @@
1module Main where
1module Main where
2
2
3-- | Here we go.
3-- | Here we go.
4−data Foo
5− = Foo {unFoo :: Int}
4+data Foo = Foo {unFoo :: Int}
6 deriving (Eq)
5 deriving (Eq)
7
6
8-- | And once again.
7-- | And once again.
data/examples/declaration/data/strictness-out.hs+3−1
@@ -1,4 +1,6 @@
1module Main where
1module Main where
2
2
3-- | Something.
3-- | Something.
4+data Foo
4−data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
5+ = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
6+ | Foo2 {a :: {-# UNPACK #-} Maybe Int && Bool}
data/examples/declaration/data/strictness.hs+3−1
@@ -2,4 +2,6 @@ module Main where
2
2
3-- | Something.
3-- | Something.
4
4
5+data Foo
5−data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
6+ = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
7+ | Foo2 { a :: {-# UNPACK #-} Maybe Int && Bool }
data/examples/declaration/data/unnamed-field-comment-0-out.hsnew file+7
@@ -0,0 +1,7 @@
1+data Foo
2+ = -- | Bar
3+ Bar
4+ Field1
5+ -- ^ Field 1
6+ Field2
7+ -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-0.hsnew file+5
@@ -0,0 +1,5 @@
1+data Foo
2+ = -- | Bar
3+ Bar
4+ Field1 -- ^ Field 1
5+ Field2 -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-1-out.hsnew file+5
@@ -0,0 +1,5 @@
1+data X
2+ = B
3+ !Int
4+ -- ^ y
5+ C
data/examples/declaration/data/unnamed-field-comment-1.hsnew file+4
@@ -0,0 +1,4 @@
1+data X
2+ = B
3+ !Int -- ^ y
4+ C
data/examples/declaration/data/with-comment-out.hsnew file+4
@@ -0,0 +1,4 @@
1+data A
2+ = B -- C
3+ | -- D
4+ E
data/examples/declaration/data/with-comment.hsnew file+5
@@ -0,0 +1,5 @@
1+data A =
2+ B -- C
3+
4+ -- D
5+ | E
data/examples/declaration/data/with-weird-haddock-out.hsnew file+4
@@ -0,0 +1,4 @@
1+data PlusLevel' t
2+ = -- | @n + ℓ@.
3+ Plus Integer (LevelAtom' t)
4+ deriving (Show, Data)
data/examples/declaration/data/with-weird-haddock.hsnew file+2
@@ -0,0 +1,2 @@
1+data PlusLevel' t = Plus Integer (LevelAtom' t) -- ^ @n + ℓ@.
2+ deriving (Show, Data)
data/examples/declaration/foreign/foreign-export-out.hs+2−1
@@ -2,7 +2,8 @@ foreign export ccall foo :: Int -> IO Int
2
2
3-- | 'foreignTomFun' is a very important thing
3-- | 'foreignTomFun' is a very important thing
4foreign export ccall "tomography"
4foreign export ccall "tomography"
5+ foreignTomFun ::
5− foreignTomFun :: StablePtr Storage {- Storage is bad -} -> TomForegin
6+ StablePtr Storage {- Storage is bad -} -> TomForegin
6
7
7foreign export {- We can't use capi here -} ccall "dynamic"
8foreign export {- We can't use capi here -} ccall "dynamic"
8 export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
9 export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
data/examples/declaration/instance/associated-data-out.hs−2
@@ -11,9 +11,7 @@ instance Foo Double where
11 Double
11 Double
12
12
13instance Foo [a] where
13instance Foo [a] where
14−
15 data Bar [a]
14 data Bar [a]
16 = ListBar [Bar a]
15 = ListBar [Bar a]
17−
18 data Baz [a]
16 data Baz [a]
19 = ListBaz
17 = ListBaz
data/examples/declaration/instance/associated-data.hs+1
@@ -13,6 +13,7 @@ instance Foo Double where
13
13
14instance Foo [a]
14instance Foo [a]
15 where
15 where
16+
16 data Bar [a] =
17 data Bar [a] =
17 ListBar [Bar a]
18 ListBar [Bar a]
18 data Baz [a] =
19 data Baz [a] =
data/examples/declaration/instance/associated-types-out.hs−1
@@ -3,7 +3,6 @@
3instance Foo Int where type Bar Int = Double
3instance Foo Int where type Bar Int = Double
4
4
5instance Foo Double where
5instance Foo Double where
6−
7 type
6 type
8 Bar
7 Bar
9 Double =
8 Double =
data/examples/declaration/instance/associated-types.hs+2
@@ -9,5 +9,7 @@ instance Foo Double
9 Double
9 Double
10 =
10 =
11 [Double]
11 [Double]
12+
13+
12 type instance Baz Double
14 type instance Baz Double
13 = [Double]
15 = [Double]
data/examples/declaration/instance/data-family-instances-gadt-out.hs+4−2
@@ -3,9 +3,11 @@
3
3
4data instance Bar Int a where
4data instance Bar Int a where
5 SameBar ::
5 SameBar ::
6− Bar Int
6+ Bar
7+ Int
7 Int
8 Int
8 CloseBar :: Bar Int Double
9 CloseBar :: Bar Int Double
9 OtherBar ::
10 OtherBar ::
10− Bar Int
11+ Bar
12+ Int
11 a
13 a
data/examples/declaration/instance/data-family-instances-newtype-out.hs+3−4
@@ -1,7 +1,6 @@
1{-# LANGUAGE GADTSyntax #-}
1{-# LANGUAGE GADTSyntax #-}
2{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
3
3
4−newtype instance Foo [Double]
4+newtype instance Foo [Double] = DoubleListFoo
5− = DoubleListFoo
6− { unDoubleListFoo :: Double
5+ { unDoubleListFoo :: Double
7− }
6+ }
data/examples/declaration/instance/instance-sigs-multiple-out.hs−2
@@ -1,12 +1,10 @@
1{-# LANGUAGE InstanceSigs #-}
1{-# LANGUAGE InstanceSigs #-}
2
2
3instance Applicative [] where
3instance Applicative [] where
4−
5 pure ::
4 pure ::
6 a ->
5 a ->
7 [a]
6 [a]
8 pure a = [a]
7 pure a = [a]
9−
10 (<*>) ::
8 (<*>) ::
11 [a] -> [a] -> [a]
9 [a] -> [a] -> [a]
12 (<*>) _ _ = []
10 (<*>) _ _ = []
data/examples/declaration/instance/multi-parameter-out.hs−2
@@ -1,7 +1,5 @@
1instance MonadReader a ((->) a) where ask = id
1instance MonadReader a ((->) a) where ask = id
2
2
3instance MonadState s (State s) where
3instance MonadState s (State s) where
4−
5 get = State.get
4 get = State.get
6−
7 put = State.put
5 put = State.put
data/examples/declaration/instance/newlines-after-where-out.hsnew file+5
@@ -0,0 +1,5 @@
1+instance Num X where
2+ (+) = undefined
3+
4+instance Num Y where
5+ (+) = undefined
data/examples/declaration/instance/newlines-after-where.hsnew file+7
@@ -0,0 +1,7 @@
1+instance Num X where
2+ (+) = undefined
3+
4+instance Num Y where
5+
6+
7+ (+) = undefined
data/examples/declaration/instance/newlines-between-methods-out.hsnew file+18
@@ -0,0 +1,18 @@
1+instance Num a => Num (Diff a) where
2+ D u dudx + D v dvdx = D (u + v) (dudx + dvdx)
3+ D u dudx - D v dvdx = D (u - v) (dudx - dvdx)
4+ D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx)
5+
6+ -- Comment before definition
7+ negate (D u dudx) = D (- u) (- dudx)
8+ negate (Z u dudx) = undefined
9+
10+ -- Comment after definition
11+
12+ -- Separator
13+
14+ abs (D u _) = D (abs u) (signum u)
15+ signum (D u _) = D (signum u) 0
16+
17+ -- Comment between unrelated definitions
18+ fromInteger n = D (fromInteger n) 0
data/examples/declaration/instance/newlines-between-methods.hsnew file+16
@@ -0,0 +1,16 @@
1+instance Num a => Num (Diff a) where
2+ D u dudx + D v dvdx = D (u + v) (dudx + dvdx)
3+ D u dudx - D v dvdx = D (u - v) (dudx - dvdx)
4+ D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx)
5+
6+ -- Comment before definition
7+ negate (D u dudx) = D (-u) (-dudx)
8+ negate (Z u dudx) = undefined
9+ -- Comment after definition
10+
11+ -- Separator
12+
13+ abs (D u _) = D (abs u) (signum u)
14+ signum (D u _) = D (signum u) 0
15+ -- Comment between unrelated definitions
16+ fromInteger n = D (fromInteger n) 0
data/examples/declaration/instance/single-parameter-out.hs−2
@@ -1,9 +1,7 @@
1instance Monoid Int where (<>) x y = x + y
1instance Monoid Int where (<>) x y = x + y
2
2
3instance Enum Int where
3instance Enum Int where
4−
5 fromEnum x = x
4 fromEnum x = x
6−
7 toEnum =
5 toEnum =
8 \x ->
6 \x ->
9 x
7 x
data/examples/declaration/rewrite-rule/basic1-out.hs+2−1
@@ -10,7 +10,8 @@
10
10
11{-# RULES
11{-# RULES
12"map/map"
12"map/map"
13− map f
13+ map
14+ f
14 (map g xs) =
15 (map g xs) =
15 map
16 map
16 (f . g)
17 (f . g)
data/examples/declaration/rewrite-rule/forall-out.hs → data/examples/declaration/rewrite-rule/forall-0-out.hsrenamed

The content is the same.

data/examples/declaration/rewrite-rule/forall.hs → data/examples/declaration/rewrite-rule/forall-0.hsrenamed

The content is the same.

data/examples/declaration/rewrite-rule/forall-1-out.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}
2+
3+{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}
4+
5+{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}
6+
7+{-# RULES
8+"rd_tyvs_multiline1" forall (a :: *). forall (x :: a).
9+ id x =
10+ x
11+ #-}
12+
13+{-# RULES
14+"rd_tyvs_multiline2" forall
15+ ( a ::
16+ *
17+ ). forall
18+ ( x ::
19+ a
20+ ).
21+ id x =
22+ x
23+ #-}
data/examples/declaration/rewrite-rule/forall-1.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}
2+
3+{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}
4+
5+{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}
6+
7+{-# RULES "rd_tyvs_multiline1"
8+ forall (a :: *).
9+ forall (x :: a).
10+ id x = x #-}
11+
12+{-# RULES "rd_tyvs_multiline2"
13+ forall (a ::
14+ *).
15+ forall (x ::
16+ a).
17+ id x = x #-}
data/examples/declaration/rewrite-rule/phase-out.hs+4−2
@@ -1,6 +1,7 @@
1{-# RULES
1{-# RULES
2"map/map" [2]
2"map/map" [2]
3− map f
3+ map
4+ f
4 (map g xs) =
5 (map g xs) =
5 map
6 map
6 (f . g)
7 (f . g)
@@ -9,7 +10,8 @@
9
10
10{-# RULES
11{-# RULES
11"map/map" [1] forall x y z.
12"map/map" [1] forall x y z.
12− map f
13+ map
14+ f
13 (map g xs) =
15 (map g xs) =
14 map
16 map
15 (f . g)
17 (f . g)
data/examples/declaration/signature/minimal/minimal-out.hs−2
@@ -1,5 +1,4 @@
1class Foo a where
1class Foo a where
2−
3 {-# MINIMAL (==) | ((/=), foo) #-}
2 {-# MINIMAL (==) | ((/=), foo) #-}
4
3
5 {-# MINIMAL
4 {-# MINIMAL
@@ -12,5 +11,4 @@ class Foo a where
12 #-}
11 #-}
13
12
14 (==) :: a -> a -> Bool
13 (==) :: a -> a -> Bool
15−
16 (/=) :: a -> a -> Bool
14 (/=) :: a -> a -> Bool
data/examples/declaration/signature/specialize/specialize-instance-out.hs−4
@@ -3,16 +3,12 @@ data Foo a = Foo a
3data VT v m r = VT v m r
3data VT v m r = VT v m r
4
4
5instance (Eq a) => Eq (Foo a) where
5instance (Eq a) => Eq (Foo a) where
6−
7 {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}
6 {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}
8−
9 (==) (Foo a) (Foo b) = (==) a b
7 (==) (Foo a) (Foo b) = (==) a b
10
8
11instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where
9instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where
12−
13 {-# SPECIALIZE instance
10 {-# SPECIALIZE instance
14 ( Factored m Int => Num (VT U.Vector m Int)
11 ( Factored m Int => Num (VT U.Vector m Int)
15 )
12 )
16 #-}
13 #-}
17−
18 VT x + VT y = VT $ V.zipWith (+) x y
14 VT x + VT y = VT $ V.zipWith (+) x y
data/examples/declaration/signature/standalone-kind-out.hsnew file+13
@@ -0,0 +1,13 @@
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.hsnew file+13
@@ -0,0 +1,13 @@
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,3 +1,2 @@
1fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool)
1fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool)
2−
3fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)
2fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)
data/examples/declaration/signature/type/long-multiline-applications-out.hs+1
@@ -1,5 +1,6 @@
1functionName ::
1functionName ::
2 (C1, C2, C3, C4, C5) =>
2 (C1, C2, C3, C4, C5) =>
3+ forall a b c.
3 a ->
4 a ->
4 b ->
5 b ->
5 ( LongDataTypeName
6 ( LongDataTypeName
data/examples/declaration/signature/type/long-multiline-applications.hs+2−1
@@ -1,6 +1,7 @@
1functionName
1functionName
2 :: (C1, C2, C3, C4, C5)
2 :: (C1, C2, C3, C4, C5)
3+ => forall a b c
3− => a
4+ . a
4 -> b
5 -> b
5 -> ( LongDataTypeName
6 -> ( LongDataTypeName
6 AnotherLongDataTypeName
7 AnotherLongDataTypeName
data/examples/declaration/signature/type/multi-value-out.hs+5
@@ -2,6 +2,11 @@ foo, bar :: Int
2foo = 1
2foo = 1
3bar = 2
3bar = 2
4
4
5+a, b, c :: Int
6+a = 1
7+b = 2
8+c = 3
9+
5foo,
10foo,
6 bar,
11 bar,
7 baz ::
12 baz ::
data/examples/declaration/signature/type/multi-value.hs+5
@@ -2,6 +2,11 @@ foo, bar :: Int
2foo = 1
2foo = 1
3bar = 2
3bar = 2
4
4
5+a, b, c :: Int
6+a = 1
7+b = 2
8+c = 3
9+
5foo,
10foo,
6 bar,
11 bar,
7 baz :: Int
12 baz :: Int
data/examples/declaration/signature/type/unrelated-out.hsnew file+4
@@ -0,0 +1,4 @@
1+clientFunc1 :: SomeType1
2+clientFunc2 :: SomeType2
3+clientFunc3 :: SomeType3
4+clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz
data/examples/declaration/signature/type/unrelated.hsnew file+4
@@ -0,0 +1,4 @@
1+clientFunc1 :: SomeType1
2+clientFunc2 :: SomeType2
3+clientFunc3 :: SomeType3
4+clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz
data/examples/declaration/splice/grouped-splices-out.hsnew file+3
@@ -0,0 +1,3 @@
1+$(deriveJSON fieldLabelMod ''A)
2+$(deriveJSON fieldLabelMod ''B)
3+$(deriveJSON fieldLabelMod ''C)
data/examples/declaration/splice/grouped-splices.hsnew file+3
@@ -0,0 +1,3 @@
1+$(deriveJSON fieldLabelMod ''A)
2+$(deriveJSON fieldLabelMod ''B)
3+$(deriveJSON fieldLabelMod ''C)
data/examples/declaration/splice/splice-decl.hs−1
@@ -15,4 +15,3 @@ foo bar
15-- TemplateHaskell allows Q () at the top level
15-- TemplateHaskell allows Q () at the top level
16do
16do
17 pure []
17 pure []
18−
data/examples/declaration/type-families/closed-type-family/multi-line-out.hs+6−5
@@ -1,7 +1,7 @@
1type family
1type family
2 Id a =
2 Id a =
3− result
3+ result | result -> a
4− | result -> a where
4+ where
5 Id a =
5 Id a =
6 a
6 a
7
7
@@ -10,14 +10,15 @@ type family
10 (a :: k)
10 (a :: k)
11 b
11 b
12 c =
12 c =
13− foo
13+ foo | foo -> k b
14− | foo -> k b where
14+ where
15 G a b c =
15 G a b c =
16 (a, b)
16 (a, b)
17
17
18type family
18type family
19 F a ::
19 F a ::
20+ * -> *
20− * -> * where
21+ where
21 F Int = Double
22 F Int = Double
22 F Bool =
23 F Bool =
23 Char
24 Char
data/examples/declaration/type-families/closed-type-family/with-equal-sign-out.hsnew file+2
@@ -0,0 +1,2 @@
1+type family TF a b = result where
2+ TF a b = Int
data/examples/declaration/type-families/closed-type-family/with-equal-sign.hsnew file+2
@@ -0,0 +1,2 @@
1+type family TF a b = result where
2+ TF a b = Int
data/examples/declaration/type-families/closed-type-family/with-forall-out.hsnew file+3
@@ -0,0 +1,3 @@
1+type family G a b where
2+ forall x y. G [x] (Proxy y) = Double
3+ forall z. z `G` z = Bool
data/examples/declaration/type-families/closed-type-family/with-forall.hsnew file+3
@@ -0,0 +1,3 @@
1+type family G a b where
2+ forall x y. G [x] (Proxy y) = Double
3+ forall z. z `G` z = Bool
data/examples/declaration/type-families/type-family/operator-out.hsnew file+3
@@ -0,0 +1,3 @@
1+type family a ! b
2+
3+type family a . b
data/examples/declaration/type-families/type-family/operator.hsnew file+2
@@ -0,0 +1,2 @@
1+type family a ! b
2+type family a . b
data/examples/declaration/type-synonyms/with-weird-haddock-out.hsnew file+3
@@ -0,0 +1,3 @@
1+type Elims =
2+ -- | eliminations ordered left-to-right.
3+ [Elim]
data/examples/declaration/type-synonyms/with-weird-haddock.hsnew file+1
@@ -0,0 +1 @@
1+type Elims = [Elim] -- ^ eliminations ordered left-to-right.
data/examples/declaration/type/type-applications-out.hsnew file+3
@@ -0,0 +1,3 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+type P = K @Bool @(Bool :: *) 'True 'False
data/examples/declaration/type/type-applications.hsnew file+3
@@ -0,0 +1,3 @@
1+{-# LANGUAGE TypeApplications #-}
2+
3+type P = K @Bool @(Bool :: *) 'True 'False
data/examples/declaration/type/visible-forall-out.hsnew file+2
@@ -0,0 +1,2 @@
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.hsnew file+2
@@ -0,0 +1,2 @@
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/application-0-out.hsnew file+17
@@ -0,0 +1,17 @@
1+foo =
2+ f1
3+ p1
4+ p2
5+ p3
6+
7+foo' =
8+ f2
9+ p1
10+ p2
11+ p3
12+
13+foo'' =
14+ f3
15+ p1
16+ p2
17+ p3
data/examples/declaration/value/function/application-0.hsnew file+12
@@ -0,0 +1,12 @@
1+foo =
2+ f1
3+ p1
4+ p2 p3
5+
6+foo' = f2 p1
7+ p2
8+ p3
9+
10+foo'' =
11+ f3 p1 p2
12+ p3
data/examples/declaration/value/function/application-1-out.hsnew file+19
@@ -0,0 +1,19 @@
1+main =
2+ do
3+ x
4+ y
5+ z
6+
7+main =
8+ case foo of
9+ x -> a
10+ foo
11+ a
12+ b
13+
14+main =
15+ do
16+ if x then y else z
17+ foo
18+ a
19+ b
data/examples/declaration/value/function/application-1.hsnew file+14
@@ -0,0 +1,14 @@
1+main =
2+ do
3+ x
4+ y
5+ z
6+
7+main =
8+ case foo of
9+ x -> a
10+ foo a b
11+
12+main = do
13+ if x then y else z
14+ foo a b
data/examples/declaration/value/function/arg-breakpoints-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arg-breakpoints.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arrow/expression-applications-out.hsdeleted−9
@@ -1,9 +0,0 @@
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.hsdeleted−9
@@ -1,9 +0,0 @@
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.hsdeleted−14
@@ -1,14 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x <-
5+ case x of X -> x
6+ -<
7+ y
8+ a -< b
data/examples/declaration/value/function/arrow/multiline-case.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x
5+ <- case x of X -> x
6+ -< y
7+ a -< b
data/examples/declaration/value/function/arrow/proc-applications-out.hs+6−5
@@ -9,10 +9,11 @@ bar f x =
9 w
9 w
10 )
10 )
11 ->
11 ->
12− f -< -- The value
12+ f -- The value
13+ -<
13− ( x, -- Foo
14+ ( x, -- Foo
14− w, -- Bar
15+ w, -- Bar
15− z -- Baz
16+ z -- Baz
16− )
17+ )
17
18
18baz x = proc a -> a -<< x
19baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+18−14
@@ -19,10 +19,11 @@ foo
19 )
19 )
20 ( b,
20 ( b,
21 d
21 d
22− ) -<
23− ( b + 1, -- Funnel into arrow
24− d * b
25 )
22 )
23+ -<
24+ ( b + 1, -- Funnel into arrow
25+ d * b
26+ )
26 if x `mod` y == 0 -- Basic condition
27 if x `mod` y == 0 -- Basic condition
27 then case e of -- Only left case is relevant
28 then case e of -- Only left case is relevant
28 Left
29 Left
@@ -32,18 +33,20 @@ foo
32 let v =
33 let v =
33 u -- Actually never used
34 u -- Actually never used
34 ^ 2
35 ^ 2
35− in ( returnA -<
36+ in ( returnA
37+ -<
36− -- Just do the calculation
38+ -- Just do the calculation
37− (x + y * z)
39+ (x + y * z)
38 )
40 )
39 else do
41 else do
40 let u = x -- Let bindings bind expressions, not commands
42 let u = x -- Let bindings bind expressions, not commands
41− -- Could pattern match directly on x
43+ -- Could pattern match directly on x
42 i <- case u of
44 i <- case u of
43 0 -> (g . h -< u)
45 0 -> (g . h -< u)
44 n ->
46 n ->
45− ( ( h . g -<
47+ ( ( h . g
48+ -<
46− y -- First actual use of y
49+ y -- First actual use of y
47 )
50 )
48 )
51 )
49 returnA -< ()
52 returnA -< ()
@@ -51,8 +54,9 @@ foo
51 if i > 0
54 if i > 0
52 then ma -< ()
55 then ma -< ()
53 else returnA -< ()
56 else returnA -< ()
54− returnA -<
57+ returnA
58+ -<
55− ( i
59+ ( i
56− + x
60+ + x
57− * y -- Just do the calculation
61+ * y -- Just do the calculation
58− )
62+ )
data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs+3−2
@@ -13,5 +13,6 @@ barbaz f g = proc (a, b) -> do
13
13
14bazbar f = proc a -> do
14bazbar f = proc a -> do
15 a <-
15 a <-
16− f -<
16+ f
17+ -<
17− a
18+ a
data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs+9−7
@@ -11,10 +11,12 @@ bazbaz f g h = proc (a, b, c) -> do
11 z <-
11 z <-
12 h
12 h
13 x
13 x
14− y -<
14+ y
15+ -<
15− ( a,
16+ ( a,
16− b,
17+ b,
17− c
18+ c
18− )
19+ )
19− returnA -<
20+ returnA
21+ -<
20− (x, y, z)
22+ (x, y, z)
data/examples/declaration/value/function/arrow/proc-forms1-out.hs+8−6
@@ -7,13 +7,15 @@ foo1 f g h x =
7 (|
7 (|
8 test
8 test
9 ( h f
9 ( h f
10− . h g -<
10+ . h g
11+ -<
11− y x
12+ y x
12− . y z
13+ . y z
13 )
14 )
14 ( h g
15 ( h g
15− . h f -<
16+ . h f
17+ -<
16− y z
18+ y z
17− . y x
19+ . y x
18 )
20 )
19 |)
21 |)
data/examples/declaration/value/function/arrow/proc-forms2-out.hs+10−6
@@ -4,15 +4,19 @@ bar0 f g h x =
4 proc (y, z) ->
4 proc (y, z) ->
5 (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)
5 (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)
6
6
7−bar1 f g x y = proc _ -> f -< x &&& g -< y
7+bar1 f g x y = proc _ -> (f -< x) &&& (g -< y)
8
8
9bar2 f g h x =
9bar2 f g h x =
10 proc (y, z) ->
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
12
13bar3 f g h x =
13bar3 f g h x =
14 proc (y, z) ->
14 proc (y, z) ->
15− (h f . h g) -<
15+ ( (h f . h g)
16+ -<
16− (y x) . y z
17+ (y x) . y z
18+ ) |||
17− ||| (h g . h f) -<
19+ ( (h g . h f)
20+ -<
18− y z . (y x)
21+ 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) ->
4 proc (y, z) ->
5 (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
5 (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
6
6
7−bar1 f g x y = proc _ -> f -< x&&&g -< y
7+bar1 f g x y = proc _ -> (f -< x)&&&(g -< y)
8
8
9bar2 f g h x =
9bar2 f g h x =
10 proc (y, z) ->
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
12
13bar3 f g h x =
13bar3 f g h x =
14 proc (y, z) ->
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 |||
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+6−4
@@ -6,8 +6,10 @@ bar f g = proc a ->
6 if f a
6 if f a
7 then
7 then
8 f
8 f
9− . g -<
9+ . g
10+ -<
10− a
11+ a
11 else
12 else
12− g -<
13+ g
14+ -<
13− b
15+ b
data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+5−4
@@ -6,13 +6,14 @@ bar f g = proc a ->
6 ( ( (f)
6 ( ( (f)
7 ( g
7 ( g
8 )
8 )
9+ )
9− ) -<
10+ -<
10− ( ( ( ( ( ( g
11+ ( ( ( ( ( ( g
11− a
12+ a
13+ )
12 )
14 )
13 )
15 )
14 )
16 )
15 )
17 )
16 )
18 )
17− )
18 )
19 )
data/examples/declaration/value/function/arrow/recursive-procs-out.hs+14−10
@@ -3,17 +3,21 @@
3foo f g = proc (x, y) -> do
3foo f g = proc (x, y) -> do
4 rec a <- f y -< x
4 rec a <- f y -< x
5 b <-
5 b <-
6− g x -<
6+ g x
7+ -<
7− y
8+ y
8− bar -<
9+ bar
10+ -<
9− ( a,
11+ ( a,
10− b
12+ b
11− )
13+ )
12 rec p <-
14 rec p <-
13 f
15 f
14− p -<
16+ p
17+ -<
15− a
18+ a
16 rec q <-
19 rec q <-
17 g
20 g
18− q -<
21+ q
22+ -<
19− b
23+ b
data/examples/declaration/value/function/awkward-comment-0-out.hsnew file+6
@@ -0,0 +1,6 @@
1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2+mergeErrorReply err1 reply -- XXX where to put it?
3+ =
4+ case reply of
5+ Ok x state err2 -> Ok x state (mergeError err1 err2)
6+ Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-0.hsnew file+5
@@ -0,0 +1,5 @@
1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2+mergeErrorReply err1 reply -- XXX where to put it?
3+ = case reply of
4+ Ok x state err2 -> Ok x state (mergeError err1 err2)
5+ Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-1-out.hsnew file+9
@@ -0,0 +1,9 @@
1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2+doForeign x = x
3+ where
4+ splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits
5+ =
6+ do
7+ let l' = toFDesc l
8+ r' <- irTerm (sMN 0 "__foreignCall") vs env r
9+ return (l', r')
data/examples/declaration/value/function/awkward-comment-1.hsnew file+7
@@ -0,0 +1,7 @@
1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2+doForeign x = x
3+ where
4+ splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
5+ = do let l' = toFDesc l
6+ r' <- irTerm (sMN 0 "__foreignCall") vs env r
7+ return (l', r')
data/examples/declaration/value/function/blank-lines-let-out.hsnew file+6
@@ -0,0 +1,6 @@
1+foo =
2+ let x = 10
3+
4+ y = 11
5+ z = 12
6+ in x + y + z
data/examples/declaration/value/function/blank-lines-let.hsnew file+9
@@ -0,0 +1,9 @@
1+foo =
2+ let
3+
4+ x = 10
5+
6+ y = 11
7+ z = 12
8+
9+ in x + y + z
data/examples/declaration/value/function/blank-lines-where-out.hsnew file+6
@@ -0,0 +1,6 @@
1+foo = x + y + z
2+ where
3+ x = 10
4+
5+ y = 11
6+ z = 12
data/examples/declaration/value/function/blank-lines-where.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = x + y + z
2+ where
3+
4+ x = 10
5+
6+ y = 11
7+ z = 12
data/examples/declaration/value/function/block-arguments-out.hs+7
@@ -25,3 +25,10 @@ f7 = foo \x -> y
25
25
26f8 = foo \x ->
26f8 = foo \x ->
27 y
27 y
28+
29+f9 = foo do { bar } baz
30+
31+f10 = foo
32+ do a
33+ do b
34+ do c
data/examples/declaration/value/function/block-arguments.hs+7
@@ -21,3 +21,10 @@ f7 = foo \x -> y
21
21
22f8 = foo \x ->
22f8 = foo \x ->
23 y
23 y
24+
25+f9 = foo do { bar } baz
26+
27+f10 = foo
28+ do { a }
29+ do { b }
30+ do c
data/examples/declaration/value/function/do/blocks-out.hs+1
@@ -15,4 +15,5 @@ readInClause = do
15 <|> do
15 <|> do
16 optional g_Semi
16 optional g_Semi
17 void allspacing
17 void allspacing
18+
18 return things
19 return things
data/examples/declaration/value/function/do/comment-alignment-out.hsnew file+9
@@ -0,0 +1,9 @@
1+main = do
2+ case blah of
3+ Nothing -> return ()
4+ Just xs -> do
5+ forM_ xs foo
6+ bar
7+ -- and here it goes
8+ unless bobla $
9+ quux
data/examples/declaration/value/function/do/comment-alignment.hsnew file+9
@@ -0,0 +1,9 @@
1+main = do
2+ case blah of
3+ Nothing -> return ()
4+ Just xs -> do
5+ forM_ xs foo
6+ bar
7+ -- and here it goes
8+ unless bobla $
9+ quux
data/examples/declaration/value/function/do/comment-spacing-out.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = do
2+ bar
3+ -- foo
4+ baz
5+
6+ -- foo
7+ quux
data/examples/declaration/value/function/do/comment-spacing.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = do
2+ bar
3+ -- foo
4+ baz
5+
6+ -- foo
7+ quux
data/examples/declaration/value/function/do/recursive-do-rec-out.hs+5
@@ -2,13 +2,18 @@
2
2
3foo = do
3foo = do
4 rec a <- b + 5
4 rec a <- b + 5
5+
5 let d = c
6 let d = c
7+
6 b <- a * 5
8 b <- a * 5
9+
7 something
10 something
11+
8 c <- a + b
12 c <- a + b
9 print c
13 print c
10 rec something $ do
14 rec something $ do
11 x <- a
15 x <- a
12 print x
16 print x
17+
13 y <- c
18 y <- c
14 print y
19 print y
data/examples/declaration/value/function/if-with-comment-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ if undefined
3+ then -- then comment
4+ undefined
5+ else -- else comment
6+
7+ do
8+ undefined
data/examples/declaration/value/function/if-with-comment.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ if undefined
3+ -- then comment
4+ then undefined
5+ -- else comment
6+ else
7+ do
8+ undefined
data/examples/declaration/value/function/implicit-params-out.hs+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE ImplicitParams #-}
1{-# LANGUAGE ImplicitParams #-}
2
2
3sortBy :: (a -> a -> Bool) -> [a] -> [a]
3sortBy :: (a -> a -> Bool) -> [a] -> [a]
4+sortBy = undefined
4
5
5sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
6sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
6sort = sortBy ?cmp
7sort = sortBy ?cmp
data/examples/declaration/value/function/implicit-params.hs+2
@@ -1,6 +1,8 @@
1{-# LANGUAGE ImplicitParams #-}
1{-# LANGUAGE ImplicitParams #-}
2sortBy :: (a -> a -> Bool) -> [a] -> [a]
2sortBy :: (a -> a -> Bool) -> [a] -> [a]
3
3
4+sortBy = undefined
5+
4sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
6sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
5sort = sortBy ?cmp
7sort = sortBy ?cmp
6
8
data/examples/declaration/value/function/infix/dollar-chains-out.hs+7−3
@@ -13,6 +13,10 @@ foo =
13 throwIO (OrmoluCppEnabled path)
13 throwIO (OrmoluCppEnabled path)
14
14
15foo =
15foo =
16− bar
16+ bar $
17− $ baz
17+ baz $
18− $ quux
18+ quux
19+
20+x =
21+ case l of { A -> B } $
22+ case q of r -> s
data/examples/declaration/value/function/infix/dollar-chains.hs+4
@@ -16,3 +16,7 @@ foo =
16 bar
16 bar
17 $ baz
17 $ baz
18 $ quux
18 $ quux
19+
20+x =
21+ case l of { A -> B } $
22+ case q of r -> s
data/examples/declaration/value/function/infix/hanging-out.hs+4−3
@@ -17,6 +17,7 @@ update =
17 `catch` \case
17 `catch` \case
18 a -> a
18 a -> a
19
19
20−foo = bar
20+foo =
21+ bar
21− ++ case foo of
22+ ++ case foo of
22− a -> a
23+ a -> a
data/examples/declaration/value/function/infix/lenses-out.hs+8−7
@@ -1,11 +1,12 @@
1lenses =
1lenses =
2+ Just $
2− Just $ M.fromList $
3+ M.fromList $
3− "type" .= ("user.connection" :: Text)
4+ "type" .= ("user.connection" :: Text)
4− # "connection" .= uc
5+ # "connection" .= uc
5− # "user" .= case name of
6+ # "user" .= case name of
6− Just n -> Just $ object ["name" .= n]
7+ Just n -> Just $ object ["name" .= n]
7− Nothing -> Nothing
8+ Nothing -> Nothing
8− # []
9+ # []
9
10
10foo =
11foo =
11 a
12 a
data/examples/declaration/value/function/let-single-line-out.hs−1
@@ -5,7 +5,6 @@ foo x = let x = z where { z = 2 }; a = 3 in x
5foo x = let g :: Int -> Int; g = id in ()
5foo x = let g :: Int -> Int; g = id in ()
6
6
7let a = b; c = do { foo; bar }; d = baz in b
7let a = b; c = do { foo; bar }; d = baz in b
8−
9let a = case True of { True -> foo; False -> bar }; b = foo a in b
8let a = case True of { True -> foo; False -> bar }; b = foo a in b
10
9
11foo x = let ?g = id; ?f = g in x
10foo x = let ?g = id; ?f = g in x
data/examples/declaration/value/function/list-notation-0-out.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ testCase "Foo" testFoo :
3+ testCase "Bar" testBar :
4+ testCase "Baz" testBaz :
5+ []
data/examples/declaration/value/function/list-notation-0.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ testCase "Foo" testFoo :
3+ testCase "Bar" testBar :
4+ testCase "Baz" testBaz :
5+ []
data/examples/declaration/value/function/list-notation-1-out.hsnew file+8
@@ -0,0 +1,8 @@
1+instance A.ToJSON UpdateTable where
2+ toJSON a =
3+ A.object $
4+ "TableName" .= updateTableName a :
5+ "ProvisionedThroughput" .= updateProvisionedThroughput a :
6+ case updateGlobalSecondaryIndexUpdates a of
7+ [] -> []
8+ l -> ["GlobalSecondaryIndexUpdates" .= l]
data/examples/declaration/value/function/list-notation-1.hsnew file+7
@@ -0,0 +1,7 @@
1+instance A.ToJSON UpdateTable where
2+ toJSON a = A.object
3+ $ "TableName" .= updateTableName a
4+ : "ProvisionedThroughput" .= updateProvisionedThroughput a
5+ : case updateGlobalSecondaryIndexUpdates a of
6+ [] -> []
7+ l -> [ "GlobalSecondaryIndexUpdates" .= l ]
data/examples/declaration/value/function/list-notation-2-out.hsnew file+6
@@ -0,0 +1,6 @@
1+-- A list of the element and all its parents up to the root node.
2+getPath tree t =
3+ t :
4+ case Map.lookup (getId t) tree of
5+ Nothing -> []
6+ Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-2.hsnew file+5
@@ -0,0 +1,5 @@
1+-- A list of the element and all its parents up to the root node.
2+getPath tree t = t :
3+ case Map.lookup (getId t) tree of
4+ Nothing -> []
5+ Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-3-out.hsnew file+12
@@ -0,0 +1,12 @@
1+foo =
2+ reportSDoc "tc.cc" 30 $
3+ sep $ do
4+ (prettyTCM q <+> " before compilation") : do
5+ map (prettyTCM . map unArg . clPats) cls
6+
7+foo =
8+ reportSDoc "tc.cc" 30 $
9+ sep $ do
10+ (prettyTCM q <+> " before compilation") :
11+ do
12+ map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/list-notation-3.hsnew file+10
@@ -0,0 +1,10 @@
1+foo =
2+ reportSDoc "tc.cc" 30 $ sep $ do
3+ (prettyTCM q <+> " before compilation") : do
4+ map (prettyTCM . map unArg . clPats) cls
5+
6+foo =
7+ reportSDoc "tc.cc" 30 $ sep $ do
8+ (prettyTCM q <+> " before compilation") :
9+ do
10+ map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/multi-way-if-out.hs+10−4
@@ -4,7 +4,13 @@ foo x = if | x == 5 -> 5
4
4
5bar x y =
5bar x y =
6 if
6 if
7− | x > y -> x
7+ | x > y -> x
8− | x < y ->
8+ | x < y ->
9− y
9+ y
10− | otherwise -> x
10+ | otherwise -> x
11+
12+baz =
13+ if
14+ | p -> f
15+ | otherwise -> g
16+ x
data/examples/declaration/value/function/multi-way-if.hs+5
@@ -7,3 +7,8 @@ bar x y = if
7 | x < y
7 | x < y
8 -> y
8 -> y
9 | otherwise -> x
9 | otherwise -> x
10+
11+baz =
12+ if | p -> f
13+ | otherwise -> g
14+ x
data/examples/declaration/value/function/operator-comments-2-out.hsnew file+5
@@ -0,0 +1,5 @@
1+x =
2+ y
3+ ++ f g -- commentA
4+ -- commentB
5+ -- commentC
data/examples/declaration/value/function/operator-comments-2.hsnew file+4
@@ -0,0 +1,4 @@
1+x =
2+ y ++ -- commentA
3+-- commentB
4+ f g -- commentC
data/examples/declaration/value/function/operators-0-out.hsnew file+5
@@ -0,0 +1,5 @@
1+a =
2+ b & c .~ d
3+ & e
4+ %~ f
5+ g
data/examples/declaration/value/function/operators-0.hsnew file+4
@@ -0,0 +1,4 @@
1+a =
2+ b & c .~ d
3+ & e %~ f
4+ g
data/examples/declaration/value/function/operators-1-out.hsnew file+4
@@ -0,0 +1,4 @@
1+foo =
2+ f
3+ . g
4+ =<< h . i
data/examples/declaration/value/function/operators-1.hsnew file+3
@@ -0,0 +1,3 @@
1+foo = f
2+ . g
3+ =<< h . i
data/examples/declaration/value/function/operators-2-out.hsnew file+4
@@ -0,0 +1,4 @@
1+foo n
2+ | x || y && z || n ** x
3+ || x && n =
4+ 42
data/examples/declaration/value/function/operators-2.hsnew file+4
@@ -0,0 +1,4 @@
1+foo n
2+ | x || y && z || n ** x
3+ || x && n =
4+ 42
data/examples/declaration/value/function/operators-3-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ op <> n <+> colon <+> prettySe <+> text "="
3+ <+> prettySe <> text sc
data/examples/declaration/value/function/operators-3.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ op <> n <+> colon <+> prettySe <+> text "=" <+>
3+ prettySe <> text sc
data/examples/declaration/value/function/operators-4-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon
3+ <+> align <> prettyPs
data/examples/declaration/value/function/operators-4.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon <+>
3+ align <> prettyPs
data/examples/declaration/value/function/operators-5-out.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ map bar $
3+ [ baz
4+ ]
5+ ++ quux
data/examples/declaration/value/function/operators-5.hsnew file+4
@@ -0,0 +1,4 @@
1+foo =
2+ map bar $
3+ [ baz
4+ ] ++ quux
data/examples/declaration/value/function/operators-6-out.hsnew file+9
@@ -0,0 +1,9 @@
1+type PermuteRef =
2+ "a"
3+ :> ( "b" :> "c" :> End
4+ :<|> "c" :> "b" :> End
5+ )
6+ :<|> "b"
7+ :> ( "a" :> "c" :> End
8+ :<|> "c" :> "a" :> End
9+ )
data/examples/declaration/value/function/operators-6.hsnew file+7
@@ -0,0 +1,7 @@
1+type PermuteRef =
2+ "a" :> ( "b" :> "c" :> End
3+ :<|> "c" :> "b" :> End
4+ )
5+ :<|> "b" :> ( "a" :> "c" :> End
6+ :<|> "c" :> "a" :> End
7+ )
data/examples/declaration/value/function/overindentation-out.hs+11−9
@@ -1,9 +1,11 @@
1−reallyincrediblyLongName = f
1+reallyincrediblyLongName =
2+ f
2− a
3+ a
3− A
4+ A
4− { reallyincrediblyLongName = f
5+ { reallyincrediblyLongName =
6+ f
5− a
7+ a
6− A
8+ A
7− { reallyincrediblyLongName
9+ { reallyincrediblyLongName
8− }
10+ }
9− }
11+ }
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
10 ] -> a + b
11
11
12g xs = case xs of
12g xs = case xs of
13− ( a :
13+ ( a
14− bs
14+ : bs
15 ) -> a + b
15 ) -> a + b
data/examples/declaration/value/function/pattern/view-pattern-out.hs−3
@@ -13,6 +13,3 @@ multiline
13 bar
13 bar
14 baz
14 baz
15 ) = True
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,6 +10,3 @@ g ((f, _), f -> 4) = True
10multiline (t -> Foo
10multiline (t -> Foo
11 bar
11 bar
12 baz) = True
12 baz) = True
13−
14−-- https://github.com/tweag/ormolu/issues/343
15−foo = (f -> 4)
data/examples/declaration/value/function/record-constructors-out.hsdeleted−27
@@ -1,27 +0,0 @@
1−foo = Foo {a = 3}
2−
3−bar = Bar
4− { abc = foo,
5− def = Foo {a = 10}
6− }
7−
8−baz = Baz {}
9−
10−sym = Foo {(+) = 3}
11−
12−aLongVariableName =
13− ALongRecordName
14− { short = baz,
15− aLongRecordFieldName = YetAnotherLongRecordName
16− { yetAnotherLongRecordFieldName = "a long string"
17− },
18− aLongRecordFieldName2 = Just YetAnotherLongRecordName
19− { yetAnotherLongRecordFieldName = "a long string",
20− yetAnotherLongRecordFieldName =
21− Just
22− "a long string"
23− },
24− aLongRecordFieldName3 = do
25− foo
26− bar
27− }
data/examples/declaration/value/function/record/constructors-out.hsnew file+31
@@ -0,0 +1,31 @@
1+foo = Foo {a = 3}
2+
3+bar =
4+ Bar
5+ { abc = foo,
6+ def = Foo {a = 10}
7+ }
8+
9+baz = Baz {}
10+
11+sym = Foo {(+) = 3}
12+
13+aLongVariableName =
14+ ALongRecordName
15+ { short = baz,
16+ aLongRecordFieldName =
17+ YetAnotherLongRecordName
18+ { yetAnotherLongRecordFieldName = "a long string"
19+ },
20+ aLongRecordFieldName2 =
21+ Just
22+ YetAnotherLongRecordName
23+ { yetAnotherLongRecordFieldName = "a long string",
24+ yetAnotherLongRecordFieldName =
25+ Just
26+ "a long string"
27+ },
28+ aLongRecordFieldName3 = do
29+ foo
30+ bar
31+ }
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.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
2+
3+data Foo = Foo {bar :: Int}
4+
5+mfoo = fmap (.bar) $ Nothing
6+
7+bar = (Foo 1).bar
8+
9+fooplus f n = f{foo = f.bar + n}
10+
11+fooplus' f n = f {foo = f.bar + n}
12+
13+fooplus'' f n = f {foo = f.bar + n}
14+
15+fooplus''' f n = f {foo = f.bar + n}
data/examples/declaration/value/function/record/dot.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
2+data Foo = Foo { bar :: Int }
3+
4+mfoo = fmap (.bar) $ Nothing
5+
6+bar = ( Foo 1).bar
7+
8+fooplus f n = f{foo = f.bar + n}
9+
10+fooplus' f n = f { foo = f.bar + n}
11+
12+fooplus'' f n = f {foo = f.bar + n}
13+
14+fooplus''' f n = f{ foo = f.bar + n}
data/examples/declaration/value/function/record/hanging-after-equal-con-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ Foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-con.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = Foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record/hanging-after-equal-update-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-update.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record/inter-comments-out.hsnew file+13
@@ -0,0 +1,13 @@
1+x =
2+ Just
3+ -- comment
4+ A
5+ { x
6+ }
7+
8+x =
9+ Just
10+ -- comment
11+ a
12+ { x
13+ }
data/examples/declaration/value/function/record/inter-comments.hsnew file+11
@@ -0,0 +1,11 @@
1+x = Just
2+ -- comment
3+ A
4+ { x
5+ }
6+
7+x = Just
8+ -- comment
9+ a
10+ { x
11+ }
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+7−6
@@ -3,11 +3,12 @@
3
3
4foo x y = Foo {x, y}
4foo x y = Foo {x, y}
5
5
6−bar x y z = Bar
6+bar x y z =
7+ Bar
7− { x,
8+ { x,
8− y,
9+ y,
9− z,
10+ z,
10− ..
11+ ..
11− }
12+ }
12
13
13baz = Baz {..}
14baz = Baz {..}
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/static-pointers-out.hs+2−1
@@ -14,6 +14,7 @@ bar =
14baz :: StaticPtr Bool
14baz :: StaticPtr Bool
15baz =
15baz =
16 static
16 static
17− ( fun 1
17+ ( fun
18+ 1
18 2
19 2
19 )
20 )
data/examples/declaration/value/function/type-applications-and-splice-out.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [|sing @ $(symFQN name)|]
data/examples/declaration/value/function/type-applications-and-splice.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [| sing @ $(symFQN name) |]
data/examples/declaration/value/function/type-applications-out.hs+6
@@ -8,3 +8,9 @@ baz =
8 f @Int @String
8 f @Int @String
9 a
9 a
10 b
10 b
11+
12+goo =
13+ hash
14+ @(HASH TPraosStandardCrypto)
15+ @ByteString
16+ "And the lamb lies down on Broadway"
data/examples/declaration/value/function/type-applications.hs+5
@@ -6,3 +6,8 @@ bar = f @(Maybe Int) a b
6
6
7baz = f @Int @String
7baz = f @Int @String
8 a b
8 a b
9+
10+goo = hash
11+ @(HASH TPraosStandardCrypto)
12+ @ByteString
13+ "And the lamb lies down on Broadway"
data/examples/import/deduplication-bug-out.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1 (..), Baz1)
2+import Foo2 (Bar2 (..), Baz2)
3+import Foo3 (Bar3 (x1, x2, x3))
4+import Foo4 (Bar4 (x1, x2))
5+import Foo5 (Bar5 (x1))
6+import Foo6 (Bar6 (..))
data/examples/import/deduplication-bug.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1, Baz1, Bar1(..))
2+import Foo2 (Bar2(..), Baz2, Bar2)
3+import Foo3 (Bar3(x1,x3), Bar3(x1, x2))
4+import Foo4 (Bar4(x1), Bar4(x2))
5+import Foo5 (Bar5, Bar5(x1))
6+import Foo6 (Bar6(x1), Bar6(..))
data/examples/import/explicit-imports-out.hs+4−4
@@ -1,12 +1,12 @@
1import qualified MegaModule as M
1import qualified MegaModule as M
2− ( (<<<),
3− (>>>),
4− Either,
2+ ( Either,
5 Maybe (Just, Nothing),
3 Maybe (Just, Nothing),
6 MaybeT (..),
4 MaybeT (..),
7− Monad ((>>), (>>=), return),
5+ Monad (return, (>>), (>>=)),
8 MonadBaseControl,
6 MonadBaseControl,
9 join,
7 join,
10 liftIO,
8 liftIO,
11 void,
9 void,
10+ (<<<),
11+ (>>>),
12 )
12 )
data/examples/import/explicit-imports-with-comments-out.hs+3−2
@@ -1,6 +1,7 @@
1import qualified MegaModule as M
1import qualified MegaModule as M
2 ( -- (1)
2 ( -- (1)
3− (<<<), -- (2)
3+ -- (2)
4− (>>>),
5 Either, -- (3)
4 Either, -- (3)
5+ (<<<),
6+ (>>>),
6 )
7 )
data/examples/import/merging-0-out.hsnew file+3
@@ -0,0 +1,3 @@
1+import Foo
2+import Foo (bar, foo)
3+import Foo as F
data/examples/import/merging-0.hsnew file+4
@@ -0,0 +1,4 @@
1+import Foo
2+import Foo (foo)
3+import Foo (bar)
4+import Foo as F
data/examples/import/merging-1-out.hsnew file+2
@@ -0,0 +1,2 @@
1+import "bar" Foo (bar)
2+import "foo" Foo (baz, foo)
data/examples/import/merging-1.hsnew file+3
@@ -0,0 +1,3 @@
1+import "foo" Foo (foo)
2+import "bar" Foo (bar)
3+import "foo" Foo (baz)
data/examples/import/merging-2-out.hsnew file+2
@@ -0,0 +1,2 @@
1+import Foo hiding (bar4, foo2)
2+import qualified Foo (bar3, foo1)
data/examples/import/merging-2.hsnew file+4
@@ -0,0 +1,4 @@
1+import qualified Foo (foo1)
2+import Foo hiding (foo2)
3+import qualified Foo (bar3)
4+import Foo hiding (bar4)
data/examples/import/misc-out.hs−6
@@ -1,11 +1,5 @@
1import A hiding
1import A hiding
2 ( foobarbazqux,
2 ( foobarbazqux,
3− foobarbazqux,
4− foobarbazqux,
5− foobarbazqux,
6− foobarbazqux,
7− foobarbazqux,
8− foobarbazqux,
9 )
3 )
10import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)
4import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)
11import Name hiding ()
5import Name hiding ()
data/examples/import/nested-explicit-imports-out.hs+6−6
@@ -1,10 +1,10 @@
1import qualified MegaModule as M
1import qualified MegaModule as M
2− ( (<<<),
3− (>>>),
4− Either,
2+ ( Either,
5 Monad
3 Monad
4+ ( return,
6− ( (>>),
5+ (>>),
7− (>>=),
6+ (>>=)
8− return
9 ),
7 ),
8+ (<<<),
9+ (>>>),
10 )
10 )
data/examples/import/qualified-post-out.hsnew file+5
@@ -0,0 +1,5 @@
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.hsnew file+5
@@ -0,0 +1,5 @@
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
1module P where
2
2
3−import Prelude hiding ((.), id)
3+import Prelude hiding (id, (.))
4import qualified Prelude
4import qualified Prelude
data/examples/import/simple-out.hs+2−3
@@ -1,6 +1,5 @@
1import Data.Text
1import Data.Text
2−import Data.Text
3−import qualified Data.Text as T
4−import qualified Data.Text (a, b, c)
5import Data.Text (a, b, c)
2import Data.Text (a, b, c)
6import Data.Text hiding (a, b, c)
3import Data.Text hiding (a, b, c)
4+import qualified Data.Text (a, b, c)
5+import qualified Data.Text as T
data/examples/import/simple.hs+2
@@ -4,3 +4,5 @@ import qualified Data.Text as T
4import qualified Data.Text (a, c, b)
4import qualified Data.Text (a, c, b)
5import Data.Text (a, b, c)
5import Data.Text (a, b, c)
6import Data.Text hiding (c, b, a)
6import Data.Text hiding (c, b, a)
7+import Data.Text (a, b, c, b, a)
8+import Data.Text hiding (c, b, a, b, c)
data/examples/import/sorted-export-list-out.hsnew file+1
@@ -0,0 +1 @@
1+import Linear.Vector (Additive (..), (*^), (^*))
data/examples/import/sorted-export-list.hsnew file+1
@@ -0,0 +1 @@
1+import Linear.Vector (Additive (..), (*^), (^*))
data/examples/module-header/double-dot-with-names-out.hs+1−6
@@ -1,11 +1,6 @@
1{-# LANGUAGE PatternSynonyms #-}
1{-# LANGUAGE PatternSynonyms #-}
2
2
3−module ExportSyntax
3+module ExportSyntax (A (.., NoA), Q (F, ..), G (T, .., U)) where
4− ( A (.., NoA),
5− Q (F, ..),
6− G (T, .., U),
7− )
8−where
9
4
10data A = A | B
5data A = A | B
11
6
data/examples/module-header/multiline2.hs+2−2
@@ -1,2 +1,2 @@
1−module Foo
1+module Foo (
2− (foo, bar, baz) where
2+ foo, bar, baz) where
data/examples/module-header/preceding-comment-with-haddock-out.hsnew file+8
@@ -0,0 +1,8 @@
1+{-
2+ Here we go.
3+-}
4+
5+-- | This is the module's Haddock.
6+module Main (main) where
7+
8+main = return ()
data/examples/module-header/preceding-comment-with-haddock.hsnew file+8
@@ -0,0 +1,8 @@
1+{-
2+ Here we go.
3+-}
4+
5+-- | This is the module's Haddock.
6+module Main (main) where
7+
8+main = return ()
data/examples/module-header/shebang-out.hs+1
@@ -1,4 +1,5 @@
1#! /usr/bin/env runhaskell
1#! /usr/bin/env runhaskell
2+
2import Prelude
3import Prelude
3
4
4main :: IO ()
5main :: IO ()
data/examples/module-header/shebang-with-pragmas-out.hsnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env stack
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+main = pure ()
data/examples/module-header/shebang-with-pragmas.hsnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env stack
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+main = pure ()
data/examples/module-header/shebang.hs+1
@@ -1,4 +1,5 @@
1#! /usr/bin/env runhaskell
1#! /usr/bin/env runhaskell
2+
2import Prelude
3import Prelude
3
4
4main :: IO ()
5main :: IO ()
data/examples/module-header/singleline-empty-out.hs+1−4
@@ -1,5 +1,2 @@
1-- | This demonstrates a BUG.
1-- | This demonstrates a BUG.
2−module Foo
2+module Foo () where
3− (
4− )
5−where
data/examples/module-header/stack-header-0-out.hsnew file+7
@@ -0,0 +1,7 @@
1+-- stack runhaskell
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+main = return ()
6+
7+-- stack runhaskell
data/examples/module-header/stack-header-0.hsnew file+4
@@ -0,0 +1,4 @@
1+-- stack runhaskell
2+{-# LANGUAGE OverloadedStrings #-}
3+main = return ()
4+-- stack runhaskell
data/examples/module-header/stack-header-1-out.hsnew file+8
@@ -0,0 +1,8 @@
1+#!/usr/bin/env stack
2+-- stack runhaskell
3+
4+{-# LANGUAGE OverloadedStrings #-}
5+
6+main = return ()
7+
8+-- stack runhaskell
data/examples/module-header/stack-header-1.hsnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env stack
2+-- stack runhaskell
3+{-# LANGUAGE OverloadedStrings #-}
4+main = return ()
5+-- stack runhaskell
data/examples/module-header/stack-header-2-out.hsnew file+12
@@ -0,0 +1,12 @@
1+#!/usr/bin/env stack
2+{- stack
3+ script
4+ --resolver lts-6.25
5+ --package turtle
6+ --package "stm async"
7+ --package http-client,http-conduit
8+-}
9+
10+{-# LANGUAGE OverloadedStrings #-}
11+
12+main = return ()
data/examples/module-header/stack-header-2.hsnew file+12
@@ -0,0 +1,12 @@
1+#!/usr/bin/env stack
2+{- stack
3+ script
4+ --resolver lts-6.25
5+ --package turtle
6+ --package "stm async"
7+ --package http-client,http-conduit
8+-}
9+
10+{-# LANGUAGE OverloadedStrings #-}
11+
12+main = return ()
data/examples/module-header/warning-pragma-multiline-out.hs+1−4
@@ -1,9 +1,6 @@
1module Test
1module Test
2 {-# DEPRECATED "This module is unstable" #-}
2 {-# DEPRECATED "This module is unstable" #-}
3− ( foo,
3+ (foo, bar, baz)
4− bar,
5− baz,
6− )
7where
4where
8
5
9import Blah
6import Blah
data/examples/module-header/warning-pragma-out.hs+3−1
@@ -1,3 +1,5 @@
1module Test
1module Test
2+ {-# WARNING
2− {-# WARNING "This module is very internal" #-}
3+ "This module is very internal"
4+ #-}
3where
5where
data/examples/other/argument-comment-out.hs−1
@@ -9,7 +9,6 @@ foo ::
9 -- | Foo
9 -- | Foo
10 Int ->
10 Int ->
11 Int
11 Int
12−
13foo ::
12foo ::
14 Foo a =>
13 Foo a =>
15 -- | Foo
14 -- | Foo
data/examples/other/comment-after-preceding-haddock-out.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+-- | A
4+
5+-- B
6+
7+type D = E
8+
9+-- | This is 'f'
10+
11+-- * Comment
12+f :: a -> b
data/examples/other/comment-after-preceding-haddock.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+-- | A
4+
5+-- B
6+
7+type D = E
8+
9+-- | This is 'f'
10+
11+-- * Comment
12+f :: a -> b
data/examples/other/comment-alignment-out.hs−1
@@ -1,5 +1,4 @@
1class Foo a where
1class Foo a where
2−
3 -- | Foo.
2 -- | Foo.
4 foo ::
3 foo ::
5 Int ->
4 Int ->
data/examples/other/comment-before-hanging-out.hsnew file+5
@@ -0,0 +1,5 @@
1+x = Just
2+ -- comment
3+ do
4+ foo
5+ bar
data/examples/other/comment-before-hanging.hsnew file+5
@@ -0,0 +1,5 @@
1+x = Just
2+ -- comment
3+ do
4+ foo
5+ bar
data/examples/other/comment-glued-together-out.hsnew file+7
@@ -0,0 +1,7 @@
1+module Main (main) where
2+
3+-- | Foo.
4+
5+-- Bar
6+main :: IO ()
7+main = return ()
data/examples/other/comment-glued-together.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+{- | Foo. -}
4+-- Bar
5+main :: IO ()
6+main = return ()
data/examples/other/comment-trailing-space-out.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-trailing-space.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-two-blocks-out.hs+2−2
@@ -2,7 +2,7 @@ newNames :: [(String, String)]
2newNames =
2newNames =
3 let (*) = flip (,)
3 let (*) = flip (,)
4 in [ "Control" * "Monad"
4 in [ "Control" * "Monad"
5− -- Foo
5+ -- Foo
6
6
7− -- Bar
7+ -- Bar
8 ]
8 ]
data/examples/other/cpp/continuation-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo :: Int
2+foo = 5
3+
4+#define message_for(a, b) \
5+ printf(#a " and " #b ": We love you!\n")
6+
7+bar :: Int
8+bar = 6
data/examples/other/cpp/continuation.hsnew file+8
@@ -0,0 +1,8 @@
1+foo :: Int
2+foo = 5
3+
4+#define message_for(a, b) \
5+ printf(#a " and " #b ": We love you!\n")
6+
7+bar :: Int
8+bar = 6
data/examples/other/cpp/lonely-hash-out.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+# if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+# endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/lonely-hash.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+# if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+# endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/separation-0a-out.hsnew file+7
@@ -0,0 +1,7 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+
5+#if !(MIN_VERSION_base(4,13,0))
6+ fail = Fail.fail
7+#endif
data/examples/other/cpp/separation-0a.hsnew file+6
@@ -0,0 +1,6 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+#if !(MIN_VERSION_base(4,13,0))
5+ fail = Fail.fail
6+#endif
data/examples/other/cpp/separation-0b-out.hsnew file+10
@@ -0,0 +1,10 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+
5+#if !(MIN_VERSION_base(4,13,0))
6+ fail = Fail.fail
7+#endif
8+
9+foo :: Int
10+foo = undefined
data/examples/other/cpp/separation-0b.hsnew file+9
@@ -0,0 +1,9 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+#if !(MIN_VERSION_base(4,13,0))
5+ fail = Fail.fail
6+#endif
7+
8+foo :: Int
9+foo = undefined
data/examples/other/cpp/separation-1a-out.hsnew file+12
@@ -0,0 +1,12 @@
1+decompressingPipe ::
2+ (PrimMonad m, MonadThrow m, MonadResource m) =>
3+ CompressionMethod ->
4+ ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+
8+#ifdef ENABLE_BZIP2
9+decompressingPipe BZip2 = BZ.bunzip2
10+#else
11+decompressingPipe BZip2 = throwM BZip2Unsupported
12+#endif
data/examples/other/cpp/separation-1a.hsnew file+11
@@ -0,0 +1,11 @@
1+decompressingPipe
2+ :: (PrimMonad m, MonadThrow m, MonadResource m)
3+ => CompressionMethod
4+ -> ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+#ifdef ENABLE_BZIP2
8+decompressingPipe BZip2 = BZ.bunzip2
9+#else
10+decompressingPipe BZip2 = throwM BZip2Unsupported
11+#endif
data/examples/other/cpp/separation-1b-out.hsnew file+15
@@ -0,0 +1,15 @@
1+decompressingPipe ::
2+ (PrimMonad m, MonadThrow m, MonadResource m) =>
3+ CompressionMethod ->
4+ ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+
8+#ifdef ENABLE_BZIP2
9+decompressingPipe BZip2 = BZ.bunzip2
10+#else
11+decompressingPipe BZip2 = throwM BZip2Unsupported
12+#endif
13+
14+foo :: Int
15+foo = undefined
data/examples/other/cpp/separation-1b.hsnew file+14
@@ -0,0 +1,14 @@
1+decompressingPipe
2+ :: (PrimMonad m, MonadThrow m, MonadResource m)
3+ => CompressionMethod
4+ -> ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+#ifdef ENABLE_BZIP2
8+decompressingPipe BZip2 = BZ.bunzip2
9+#else
10+decompressingPipe BZip2 = throwM BZip2Unsupported
11+#endif
12+
13+foo :: Int
14+foo = undefined
data/examples/other/cpp/separation-2a-out.hsnew file+9
@@ -0,0 +1,9 @@
1+ffff, ffffffff :: Natural
2+
3+#ifdef HASKELL_ZIP_DEV_MODE
4+ffff = 200
5+ffffffff = 5000
6+#else
7+ffff = 0xffff
8+ffffffff = 0xffffffff
9+#endif
data/examples/other/cpp/separation-2a.hsnew file+8
@@ -0,0 +1,8 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
data/examples/other/cpp/separation-2b-out.hsnew file+11
@@ -0,0 +1,11 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
9+
10+foo :: Int
11+foo = undefined
data/examples/other/cpp/separation-2b.hsnew file+11
@@ -0,0 +1,11 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
9+
10+foo :: Int
11+foo = undefined
data/examples/other/cpp/shifted-out.hsnew file+21
@@ -0,0 +1,21 @@
1+sinkData h compression = do
2+ (uncompressedSize, crc32, compressedSize) <-
3+ case compression of
4+ Store ->
5+ withCompression
6+ dataSink
7+ Deflate ->
8+ withCompression $
9+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink
10+#ifdef ENABLE_BZIP2
11+ BZip2 -> withCompression $
12+ BZ.bzip2 .| dataSink
13+#else
14+ BZip2 -> throwM BZip2Unsupported
15+#endif
16+ return
17+ DataDescriptor
18+ { ddCRC32 = fromIntegral crc32,
19+ ddCompressedSize = compressedSize,
20+ ddUncompressedSize = uncompressedSize
21+ }
data/examples/other/cpp/shifted.hsnew file+17
@@ -0,0 +1,17 @@
1+sinkData h compression = do
2+ (uncompressedSize, crc32, compressedSize) <-
3+ case compression of
4+ Store -> withCompression
5+ dataSink
6+ Deflate -> withCompression $
7+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink
8+#ifdef ENABLE_BZIP2
9+ BZip2 -> withCompression $
10+ BZ.bzip2 .| dataSink
11+#else
12+ BZip2 -> throwM BZip2Unsupported
13+#endif
14+ return DataDescriptor
15+ { ddCRC32 = fromIntegral crc32
16+ , ddCompressedSize = compressedSize
17+ , ddUncompressedSize = uncompressedSize }
data/examples/other/cpp/simple-import-out.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+#if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+#endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/simple-import.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+#if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+#endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/disabling/indented-fragment-out.hsnew file+7
@@ -0,0 +1,7 @@
1+foo =
2+ {- ORMOLU_DISABLE -}
3+ testCase "Foo" testFoo :
4+ testCase "Bar" testBar :
5+ testCase "Baz" testBaz :
6+ {- ORMOLU_ENABLE -}
7+ []
data/examples/other/disabling/indented-fragment.hsnew file+7
@@ -0,0 +1,7 @@
1+foo =
2+ {- ORMOLU_DISABLE -}
3+ testCase "Foo" testFoo :
4+ testCase "Bar" testBar :
5+ testCase "Baz" testBaz :
6+ {- ORMOLU_ENABLE -}
7+ []
data/examples/other/disabling/single-definition-out.hsnew file+10
@@ -0,0 +1,10 @@
1+module Foo (foo, bar) where
2+
3+{- ORMOLU_DISABLE -}
4+foo :: Int -> Int
5+foo = (+5)
6+{- ORMOLU_ENABLE -}
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/single-definition.hsnew file+10
@@ -0,0 +1,10 @@
1+module Foo (foo,bar) where
2+
3+{- ORMOLU_DISABLE -}
4+foo :: Int -> Int
5+foo = (+5)
6+{- ORMOLU_ENABLE -}
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/whole-file-out.hsnew file+10
@@ -0,0 +1,10 @@
1+{- ORMOLU_DISABLE -}
2+
3+module Foo (foo,bar) where
4+
5+foo :: Int -> Int
6+foo = (+5)
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/whole-file.hsnew file+10
@@ -0,0 +1,10 @@
1+{- ORMOLU_DISABLE -}
2+
3+module Foo (foo,bar) where
4+
5+foo :: Int -> Int
6+foo = (+5)
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/empty-forall-out.hsnew file+18
@@ -0,0 +1,18 @@
1+-- Empty foralls are handled correctly in different situations.
2+
3+data D = forall. D Int
4+
5+data G where
6+ G :: forall. Int -> G
7+
8+f :: forall. a -> a
9+f x = x
10+
11+type family T x where
12+ forall. T x = x
13+
14+{-# RULES
15+"r"
16+ r a =
17+ ()
18+ #-}
data/examples/other/empty-forall.hsnew file+17
@@ -0,0 +1,17 @@
1+-- Empty foralls are handled correctly in different situations.
2+
3+data D = forall. D Int
4+
5+data G where
6+ G :: forall. Int -> G
7+
8+f :: forall. a -> a
9+f x = x
10+
11+type family T x where
12+ forall. T x = x
13+
14+{-# RULES
15+ "r"
16+ forall. r a = ()
17+#-}
data/examples/other/haddock-sections-out.hsnew file+7
@@ -0,0 +1,7 @@
1+-- $weird #anchor#
2+--
3+-- Section 1
4+
5+-- $normal
6+--
7+-- Section 2
data/examples/other/haddock-sections.hsnew file+7
@@ -0,0 +1,7 @@
1+-- $weird #anchor#
2+--
3+-- Section 1
4+
5+-- $normal
6+--
7+-- Section 2
data/examples/other/inline-comment-0-out.hsnew file+3
@@ -0,0 +1,3 @@
1+x = ({-a-} b, c)
2+
3+y = ({-a-} b)
data/examples/other/inline-comment-0.hsnew file+3
@@ -0,0 +1,3 @@
1+x = ({-a-}b, c)
2+
3+y = ({-a-}b)
data/examples/other/inline-comment-1-out.hsnew file+12
@@ -0,0 +1,12 @@
1+showPs env ((n, _, Let _ t v) : bs) =
2+ " " ++ show n ++ " : "
3+ ++ showEnv env ({- normalise ctxt env -} t)
4+ ++ " = "
5+ ++ showEnv env ({- normalise ctxt env -} v)
6+ ++ "\n"
7+ ++ showPs env bs
8+showPs env ((n, _, b) : bs) =
9+ " " ++ show n ++ " : "
10+ ++ showEnv env ({- normalise ctxt env -} (binderTy b))
11+ ++ "\n"
12+ ++ showPs env bs
data/examples/other/inline-comment-1.hsnew file+9
@@ -0,0 +1,9 @@
1+showPs env ((n, _, Let _ t v):bs)
2+ = " " ++ show n ++ " : " ++
3+ showEnv env ({- normalise ctxt env -} t) ++ " = " ++
4+ showEnv env ({- normalise ctxt env -} v) ++
5+ "\n" ++ showPs env bs
6+showPs env ((n, _, b):bs)
7+ = " " ++ show n ++ " : " ++
8+ showEnv env ({- normalise ctxt env -} (binderTy b)) ++
9+ "\n" ++ showPs env bs
data/examples/other/multiline-forall-out.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeFamilies #-}
5+
6+-- Multiline foralls are consistent across all declarations
7+
8+data D
9+ = forall
10+ ( f ::
11+ * -> * -> *
12+ )
13+ (x :: *)
14+ (y :: *).
15+ D (f x y)
16+
17+data G where
18+ G ::
19+ forall
20+ ( f ::
21+ * -> * -> *
22+ )
23+ (x :: *)
24+ (y :: *).
25+ f x y ->
26+ G
27+
28+f ::
29+ forall
30+ ( f ::
31+ * -> * -> *
32+ )
33+ (x :: *)
34+ (y :: *).
35+ f x y ->
36+ ()
37+f = const ()
38+
39+type family T f x y where
40+ forall
41+ ( f ::
42+ * -> * -> *
43+ )
44+ (x :: *)
45+ (y :: *).
46+ T f x y =
47+ f x y
48+
49+{-# RULES
50+"r" forall
51+ ( f ::
52+ * -> * -> *
53+ )
54+ (x :: *)
55+ (y :: *).
56+ r (a :: f x y) =
57+ ()
58+ #-}
data/examples/other/multiline-forall.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE RankNTypes, PolyKinds, GADTs, TypeFamilies #-}
2+
3+-- Multiline foralls are consistent across all declarations
4+
5+data D =
6+ forall
7+ (f ::
8+ * -> * -> *)
9+ (x :: *)
10+ (y :: *)
11+ . D (f x y)
12+
13+data G where
14+ G :: forall
15+ (f ::
16+ * -> * -> *)
17+ (x :: *)
18+ (y :: *)
19+ . f x y -> G
20+
21+f :: forall
22+ (f ::
23+ * -> * -> *)
24+ (x :: *)
25+ (y :: *)
26+ . f x y -> ()
27+f = const ()
28+
29+type family T f x y where
30+ forall
31+ (f ::
32+ * -> * -> *)
33+ (x :: *)
34+ (y :: *)
35+ . T f x y = f x y
36+
37+{-# RULES
38+ "r"
39+ forall
40+ (f ::
41+ * -> * -> *)
42+ (x :: *)
43+ (y :: *)
44+ . r (a :: f x y) =
45+ ()
46+ #-}
data/examples/other/multiple-blank-line-comment-out.hsnew file+9
@@ -0,0 +1,9 @@
1+module A where
2+
3+a =
4+ b
5+ [ f
6+ {-,
7+
8+ -}
9+ ]
data/examples/other/multiple-blank-line-comment.hsnew file+10
@@ -0,0 +1,10 @@
1+module A where
2+
3+a =
4+ b
5+ [ f
6+ {-,
7+
8+
9+ -}
10+ ]
data/examples/other/pragma-comments-after-out.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+-- TODO: Fix and delete this pragma
4+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
data/examples/other/pragma-comments-after.hsnew file+3
@@ -0,0 +1,3 @@
1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- TODO: Fix and delete this pragma
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE ConstraintKinds #-}
data/examples/other/pragma-comments-out.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+-- TODO This extension is probably too dangerous, remove it.
3+{-# LANGUAGE RecordWildCards #-}
4+-- Avoid warning produced by TH.
5+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
6+
7+-- | Header comment.
8+module Foo () where
data/examples/other/pragma-comments.hsnew file+11
@@ -0,0 +1,11 @@
1+-- | Header comment.
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Avoid warning produced by TH.
6+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
7+
8+-- TODO This extension is probably too dangerous, remove it.
9+{-# LANGUAGE RecordWildCards #-}
10+
11+module Foo () where
data/examples/other/pragma-out.hs+1−4
@@ -9,7 +9,4 @@
9{-# OPTIONS_HADDOCK prune, show-extensions #-}
9{-# OPTIONS_HADDOCK prune, show-extensions #-}
10
10
11-- | Header comment.
11-- | Header comment.
12−module Foo
12+module Foo () where
13− (
14− )
15−where
data/examples/other/pragma-sorting-out.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE NondecreasingIndentation #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TypeFamilies #-}
4+-- This gap is necessary for stylish Haskell not to re-arrange
5+-- NoMonoLocalBinds before TypeFamilies
6+{-# LANGUAGE NoMonoLocalBinds #-}
7+
8+module Foo
9+ ( bar,
10+ )
11+where
data/examples/other/pragma-sorting.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE NondecreasingIndentation #-}
4+-- This gap is necessary for stylish Haskell not to re-arrange
5+-- NoMonoLocalBinds before TypeFamilies
6+{-# LANGUAGE NoMonoLocalBinds #-}
7+
8+module Foo (
9+ bar
10+ ) where
default.nix+108−44
@@ -1,7 +1,9 @@
1−{ pkgs ? (import ./nix/nixpkgs) }:
1+{ pkgs ? (import ./nix/nixpkgs { inherit system; })
2+, system ? builtins.currentSystem
3+, ormoluCompiler ? "ghc884" # the shell doesn't work with ghc8101 yet
4+}:
2
5
3let
6let
4− ormoluCompiler = "ghc865";
5 source = pkgs.lib.sourceByRegex ./. [
7 source = pkgs.lib.sourceByRegex ./. [
6 "^.*\.md$"
8 "^.*\.md$"
7 "^app.*$"
9 "^app.*$"
@@ -14,51 +16,71 @@ let
14 overrides = ormoluOverlay;
16 overrides = ormoluOverlay;
15 };
17 };
16 ormoluOverlay = self: super: {
18 ormoluOverlay = self: super: {
17− "ormolu" = super.callCabal2nix "ormolu" source { };
19+ "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };
18 };
20 };
19 ormolize = import ./nix/ormolize {
21 ormolize = import ./nix/ormolize {
20 inherit pkgs;
22 inherit pkgs;
21 inherit haskellPackages;
23 inherit haskellPackages;
22 };
24 };
23− # NOTE We have to exclude some directories for some packages because
25+ expectedFailures = [
24− # Ormolu needs files to be parsable by Haddock which is not always the
26+ "Agda"
25− # case. For example some tests and examples do not parse.
26− excludedHackageDirs = {
27− "aws" = ["Examples"];
27+ "aws"
28− "distributed-process" = ["benchmarks"];
28+ "distributed-process"
29− "esqueleto" = ["test"];
29+ "esqueleto"
30− "fay" = ["examples"];
30+ "fay"
31+ "hlint"
32+ "idris"
33+ "intero"
34+ "leksah"
35+ "pandoc"
36+ "pipes"
31− "postgrest" = ["test"];
37+ "postgrest"
32− };
38+ "purescript"
39+ "tensorflow"
40+ ] ++ (if ormoluCompiler == "ghc8101" then [] else ["lens"]);
33 ormolizedPackages = doCheck:
41 ormolizedPackages = doCheck:
34 pkgs.lib.mapAttrs (name: p: ormolize {
42 pkgs.lib.mapAttrs (name: p: ormolize {
35 package = p;
43 package = p;
36 inherit doCheck;
44 inherit doCheck;
37− excludedDirs =
45+ expectedFailures =
38− if builtins.hasAttr name excludedHackageDirs
46+ if pkgs.lib.lists.any (x: x == name) expectedFailures
39− then excludedHackageDirs.${name}
47+ then ./expected-failures + "/${name}.txt"
40− else [];
48+ else null;
41 }) haskellPackages;
49 }) haskellPackages;
42in {
50in {
43 ormolu = haskellPackages.ormolu;
51 ormolu = haskellPackages.ormolu;
52+ # We put the derivations in another attribute set to avoid building them
53+ # when nix-build is run.
54+ dev = {
55+ ormoluShell =
44− ormoluShell = haskellPackages.shellFor {
56+ haskellPackages.shellFor {
45− packages = ps: [
57+ packages = ps: [
46− ps.ormolu
58+ ps.ormolu
47− ];
59+ ];
48− buildInputs = [
60+ buildInputs = [
49− haskellPackages.cabal-install
61+ haskellPackages.cabal-install
50− haskellPackages.ghcid
62+ haskellPackages.ghcid
51− ];
63+ ];
64+ };
65+ withOrmolu = haskellPackages.shellFor {
66+ packages = ps: [];
67+ buildInputs = [
68+ haskellPackages.cabal-install
69+ haskellPackages.ormolu
70+ ];
71+ };
52 };
72 };
53 inherit ormoluOverlay ormoluCompiler;
73 inherit ormoluOverlay ormoluCompiler;
54 hackage = ormolizedPackages false;
74 hackage = ormolizedPackages false;
55 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
75 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
56 let ps = [
76 let ps = [
77+ "Agda"
57 "QuickCheck"
78 "QuickCheck"
58 "ShellCheck"
79 "ShellCheck"
59 "aeson"
80 "aeson"
60 "attoparsec"
81 "attoparsec"
61 "aws"
82 "aws"
83+ "brick"
62 "capability"
84 "capability"
63 "cassava"
85 "cassava"
64 "conduit"
86 "conduit"
@@ -70,36 +92,78 @@ in {
70 "hakyll"
92 "hakyll"
71 "haxl"
93 "haxl"
72 "hedgehog"
94 "hedgehog"
95+ "hledger"
73 "hlint"
96 "hlint"
97+ "http-client"
98+ "idris"
99+ "intero"
100+ "leksah"
101+ "lens"
74 "megaparsec"
102 "megaparsec"
103+ "optics"
75 "ormolu"
104 "ormolu"
105+ "pandoc"
106+ "parsec3"
107+ "pipes"
76 "postgrest"
108 "postgrest"
109+ "purescript"
77 "servant"
110 "servant"
78 "servant-server"
111 "servant-server"
112+ "stack"
79 "tensorflow"
113 "tensorflow"
80 "text_1_2_4_0"
114 "text_1_2_4_0"
81 "tls"
115 "tls"
82 "yesod-core"
116 "yesod-core"
83−
84− # Comment idempotence issue
85−
86− # "Agda"
87− # "brick"
88− # "hledger"
89− # "http-client"
90− # "idris"
91− # "intero"
92− # "leksah"
93− # "pandoc"
94− # "pipes"
95− # "stack"
96−
97− # Missing language extension
98−
99− # "lens" #fixed in master
100− # "purescript"
101−
102 ];
117 ];
103 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
118 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
104 );
119 );
120+ regionTests = pkgs.stdenv.mkDerivation {
121+ name = "ormolu-region-tests";
122+ src = ./region-tests;
123+ buildInputs = [
124+ haskellPackages.ormolu
125+ pkgs.diffutils
126+ ];
127+ doCheck = true;
128+ buildPhase = ''
129+ cp src.hs result-all-implicit.hs
130+ ormolu --check-idempotence --mode inplace result-all-implicit.hs
131+ cp src.hs result-all-explicit.hs
132+ ormolu --check-idempotence --mode inplace --start-line 1 --end-line 18 result-all-explicit.hs
133+ cp src.hs result-only-start.hs
134+ ormolu --check-idempotence --mode inplace --start-line 1 result-only-start.hs
135+ cp src.hs result-only-end.hs
136+ ormolu --check-idempotence --mode inplace --end-line 18 result-only-end.hs
137+ cp src.hs result-6-7.hs
138+ ormolu --check-idempotence --mode inplace --start-line 6 --end-line 7 result-6-7.hs
139+ cp src.hs result-6-8.hs
140+ ormolu --check-idempotence --mode inplace --start-line 6 --end-line 8 result-6-8.hs
141+ cp src.hs result-9-12.hs
142+ ormolu --check-idempotence --mode inplace --start-line 9 --end-line 12 result-9-12.hs
143+ cp src.hs result-17-18.hs
144+ ormolu --check-idempotence --mode inplace --start-line 17 --end-line 18 result-17-18.hs
145+ '';
146+ checkPhase = ''
147+ echo result-all-implicit.hs
148+ diff --color=always expected-result-all.hs result-all-implicit.hs
149+ echo result-all-explicit.hs
150+ diff --color=always expected-result-all.hs result-all-explicit.hs
151+ echo result-only-start.hs
152+ diff --color=always expected-result-all.hs result-only-start.hs
153+ echo result-only-end.hs
154+ diff --color=always expected-result-all.hs result-only-end.hs
155+ echo result-6-7.hs
156+ diff --color=always expected-result-6-7.hs result-6-7.hs
157+ echo result-6-8.hs
158+ diff --color=always expected-result-6-8.hs result-6-8.hs
159+ echo result-9-12.hs
160+ diff --color=always expected-result-9-12.hs result-9-12.hs
161+ echo result-17-18.hs
162+ diff --color=always expected-result-17-18.hs result-17-18.hs
163+ '';
164+ installPhase = ''
165+ mkdir "$out"
166+ find . -name '*.hs' -exec cp --parents {} $out \;
167+ '';
168+ };
105}
169}
expected-failures/Agda.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17
3+ before: " = (check_ac"
4+ after: " =\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4
9+ before: " nes\n\n "
10+ after: " nes\n\n -- Andreas"
11+Please, consider reporting the bug.
expected-failures/aws.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ Examples/PutBucketNearLine.hs:5:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ Examples/Sqs.hs:(88,3)-(90,4)
7+ parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when
8+ | the program ends as when it started.
9+ -}'
expected-failures/distributed-process.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmarks/Channels.hs:2:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ benchmarks/Spawns.hs:5:1-6
7+ parse error on input `import'
expected-failures/esqueleto.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Database/Esqueleto/Internal/Internal.hs:379:1
3+ lexical error in string/character literal at character 's'
4+
5+The GHC parser (in Haddock mode) failed:
6+ test/PostgreSQL/Test.hs:562:9-41
7+ parse error on input `-- | Check the result is not null'
expected-failures/fay.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ examples/Separated.hs:12:1-6
3+ parse error on input `module'
4+
5+The GHC parser (in Haddock mode) failed:
6+ examples/calc.hs:(4,1)-(6,2)
7+ parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs
8+-- You also need to download jquery.min.js.
9+--'
10+
11+The GHC parser (in Haddock mode) failed:
12+ examples/canvaswater.hs:(6,1)-(7,17)
13+ parse error on input `-- | A demonstration of Fay using the canvas element to display a
14+-- simple effect.'
15+
16+The GHC parser (in Haddock mode) failed:
17+ examples/data.hs:9:1-6
18+ parse error on input `module'
expected-failures/hlint.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ src/Extension.hs<rendered>:19:22
3+ before: "DoRec , -} Recursive"
4+ after: "DoRec , -}\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/Hint/Bracket.hs<rendered>:249:50
9+ before: "\" x y [r]) {ideaSpan"
10+ after: "\" x y [r])\n "
11+Please, consider reporting the bug.
expected-failures/idris.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Idris/Parser.hs:1052:1
3+ parse error on input `@'
4+
5+The GHC parser (in Haddock mode) failed:
6+ src/Idris/Parser/Expr.hs:75:1
7+ parse error on input `@'
expected-failures/intero.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/InteractiveUI.hs<rendered>:3748:33
3+ before: "text \"Try\" <+> doWha"
4+ after: "text \"Try\"\n "
5+Please, consider reporting the bug.
expected-failures/leksah.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/IDE/Pane/Modules.hs<rendered>:1184:7
3+ before: "cr\n -- show"
4+ after: "cr\n in -- show"
5+Please, consider reporting the bug.
expected-failures/lens.txtnew file+3
@@ -0,0 +1,3 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Control/Exception/Lens.hs:180:13-37
3+ parse error on input `AllocationLimitExceeded__'
expected-failures/pandoc.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmark/weigh-pandoc.hs:14:1-6
3+ parse error on input `import'
4+
5+Formatting is not idempotent:
6+ src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:613:19
7+ before: ".softbreak <$ endlin"
8+ after: ".softbreak\n <$ en"
9+Please, consider reporting the bug.
expected-failures/pipes.txtnew file+3
@@ -0,0 +1,3 @@
1+AST of input and AST of formatted code differ.
2+ at src/Pipes/Core.hs:(128,1)-(151,2)
3+Please, consider reporting the bug.
expected-failures/postgrest.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/PostgREST/DbRequestBuilder.hs<rendered>:149:24
3+ before: " || -- clients"
4+ after: " || ( origin ="
5+Please, consider reporting the bug.
expected-failures/purescript.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Language/PureScript/AST/Declarations.hs:479:1-17
3+ Invalid type signature: pattern ValueDecl :: ...
4+Perhaps you meant to use PatternSynonyms?
5+
6+The GHC parser (in Haddock mode) failed:
7+ src/Language/PureScript/AST/SourcePos.hs:99:1-22
8+ Invalid type signature: pattern NullSourceSpan :: ...
9+Perhaps you meant to use PatternSynonyms?
10+
11+The GHC parser (in Haddock mode) failed:
12+ src/Language/PureScript/Constants.hs:42:1-15
13+ Invalid type signature: pattern Discard :: ...
14+Perhaps you meant to use PatternSynonyms?
15+
16+The GHC parser (in Haddock mode) failed:
17+ src/Language/PureScript/Crash.hs:16:1-6
18+ parse error on input `import'
expected-failures/tensorflow.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ tensorflow-mnist/app/Main.hs:50:13-14
3+ parse error on input `->'
4+
5+The GHC parser (in Haddock mode) failed:
6+ tensorflow-ops/tests/RegressionTest.hs:3:1-6
7+ parse error on input `import'
format.sh+6−3
@@ -1,5 +1,5 @@
1#!/usr/bin/env nix-shell
1#!/usr/bin/env nix-shell
2−#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure
2+#!nix-shell default.nix -A dev.withOrmolu -i bash --pure
3#
3#
4# Format Ormolu using current version of Ormolu.
4# Format Ormolu using current version of Ormolu.
5
5
@@ -7,5 +7,8 @@ set -e
7
7
8export LANG="C.UTF-8"
8export LANG="C.UTF-8"
9
9
10+cabal format
11+
12+ormolu -m inplace $(find app -type f -name "*.hs")
10−ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
13+ormolu -m inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
11−ormolu --mode inplace $(find tests -type f -name "*.hs")
14+ormolu -m inplace $(find tests -type f -name "*.hs")
nix/nixpkgs/default.nix+7−3
@@ -1,9 +1,13 @@
1+{ system ? builtins.currentSystem }:
1let
2let
2− rev = "3f4144c30a6351dd79b177328ec4dea03e2ce45f";
3+ rev = "32b46dd897ab2143a609988a04d87452f0bbef59";
3− sha256 = "1qg5n60n3fr6cypihnrjw451fadps5pysj5p0vvfb320mpfvlbjb";
4+ sha256 = "1gzfrpjnr1bz9zljsyg3a4zrhk8r927sz761mrgcg56dwinkhpjk";
4 nixpkgs = builtins.fetchTarball {
5 nixpkgs = builtins.fetchTarball {
5 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
6 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
6 inherit sha256;
7 inherit sha256;
7 };
8 };
9+ pkgs = import nixpkgs {
10+ inherit system;
8− pkgs = import nixpkgs { config.allowUnfree = true; };
11+ config.allowUnfree = true;
12+ };
9in pkgs
13in pkgs
nix/ormolize/default.nix+29−13
@@ -2,32 +2,48 @@
2, haskellPackages
2, haskellPackages
3}:
3}:
4{ package
4{ package
5+, expectedFailures ? null
5, doCheck ? false
6, doCheck ? false
6−, excludedDirs ? []
7}:
7}:
8 pkgs.stdenv.mkDerivation rec {
8 pkgs.stdenv.mkDerivation rec {
9 name = package.name + "-ormolized";
9 name = package.name + "-ormolized";
10 src = package.src;
10 src = package.src;
11 buildInputs = [
11 buildInputs = [
12 haskellPackages.cpphs
12 haskellPackages.cpphs
13− (if doCheck
14− then haskellPackages.ormolu
13+ haskellPackages.ormolu
15− else pkgs.haskell.lib.dontCheck haskellPackages.ormolu)
14+ pkgs.diffutils
16 pkgs.glibcLocales
15 pkgs.glibcLocales
17 ];
16 ];
18 LANG = "en_US.UTF-8";
17 LANG = "en_US.UTF-8";
19− excludedDirsRendered =
20− if excludedDirs == []
21− then ""
22− else pkgs.lib.concatMapStringsSep " " (x: "-not -path './" + x + "/*'") excludedDirs;
23 buildPhase = ''
18 buildPhase = ''
24− find . -name '*.hs' ${excludedDirsRendered} -exec bash ${./ormolize.sh} {} \; 2> log.txt
19+ hs_files=$(find . -name '*.hs')
25− cat log.txt
20+ for hs_file in $hs_files; do
21+
22+ # drop includes
23+ sed -i '/^#include/d' "$hs_file"
24+
25+ # deal with CPP
26+ cpphs "$hs_file" --noline -DARCH_X86 > "''${hs_file}-nocpp" 2> /dev/null
27+
28+ # annoyingly, cpphs cannot modify files in place
29+ mv "''${hs_file}-nocpp" "$hs_file"
30+
31+ # preserve the original
32+ cp "$hs_file" "''${hs_file}-original"
33+ done
34+
35+ (ormolu --check-idempotence --mode inplace $hs_files || true) 2> log.txt
26 '';
36 '';
27 inherit doCheck;
37 inherit doCheck;
28− checkPhase = ''
38+ checkPhase =
39+ if expectedFailures == null
40+ then ''
41+ echo "No failures expected"
29− if [[ -s log.txt ]]; then exit 1; fi
42+ if [[ -s log.txt ]]; then exit 1; fi
43+ ''
44+ else ''
45+ diff --ignore-blank-lines --color=always ${expectedFailures} log.txt
30− '';
46+ '';
31 installPhase = ''
47 installPhase = ''
32 mkdir "$out"
48 mkdir "$out"
33 find . -name '*.hs-original' -exec cp --parents {} $out \;
49 find . -name '*.hs-original' -exec cp --parents {} $out \;
nix/ormolize/ormolize.shdeleted−17
@@ -1,17 +0,0 @@
1−set -euo pipefail
2−
3−# drop includes
4−sed -i '/^#include/d' "$1"
5−
6−# deal with CPP in a fairly straightforward way
7−cpphs "$1" --noline > "$1-nocpp" 2> /dev/null
8−
9−# annoyingly, cpphs cannot modify files in place
10−mv "$1-nocpp" "$1"
11−
12−# preserve the original
13−cp "$1" "$1-original"
14−
15−# run ormolu
16−ormolu --tolerate-cpp --check-idempotency --mode inplace "$1" ||
17− ormolu --tolerate-cpp --unsafe --mode inplace "$1"
ormolu.cabal+174−155
@@ -1,165 +1,184 @@
1−name: ormolu
2−version: 0.0.1.0
3−cabal-version: 1.18
1+cabal-version: 1.18
4−tested-with: GHC==8.6.5
2+name: ormolu
3+version: 0.1.2.0
5−license: BSD3
4+license: BSD3
6−license-file: LICENSE.md
5+license-file: LICENSE.md
7−maintainer: Mark Karpov <mark.karpov@tweag.io>
6+maintainer: Mark Karpov <mark.karpov@tweag.io>
7+tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1
8−homepage: https://github.com/tweag/ormolu
8+homepage: https://github.com/tweag/ormolu
9−bug-reports: https://github.com/tweag/ormolu/issues
9+bug-reports: https://github.com/tweag/ormolu/issues
10+synopsis: A formatter for Haskell source code
11+description: A formatter for Haskell source code.
10−category: Development, Formatting
12+category: Development, Formatting
11−synopsis: A formatter for Haskell source code
12−build-type: Simple
13+build-type: Simple
13−description: A formatter for Haskell source code.
14+data-files:
14−extra-doc-files: CONTRIBUTING.md
15− , CHANGELOG.md
16− , DESIGN.md
17− , README.md
18−data-files: data/examples/declaration/annotation/*.hs
15+ data/examples/declaration/annotation/*.hs
19− , data/examples/declaration/class/*.hs
16+ data/examples/declaration/class/*.hs
20− , data/examples/declaration/data/*.hs
17+ data/examples/declaration/data/*.hs
21− , data/examples/declaration/data/gadt/*.hs
18+ data/examples/declaration/data/gadt/*.hs
22− , data/examples/declaration/default/*.hs
19+ data/examples/declaration/default/*.hs
23− , data/examples/declaration/deriving/*.hs
20+ data/examples/declaration/deriving/*.hs
24− , data/examples/declaration/foreign/*.hs
21+ data/examples/declaration/foreign/*.hs
25− , data/examples/declaration/instance/*.hs
22+ data/examples/declaration/instance/*.hs
26− , data/examples/declaration/rewrite-rule/*.hs
23+ data/examples/declaration/rewrite-rule/*.hs
27− , data/examples/declaration/role-annotation/*.hs
24+ data/examples/declaration/role-annotation/*.hs
28− , data/examples/declaration/signature/complete/*.hs
25+ data/examples/declaration/signature/complete/*.hs
29− , data/examples/declaration/signature/fixity/*.hs
26+ data/examples/declaration/signature/fixity/*.hs
30− , data/examples/declaration/signature/inline/*.hs
27+ data/examples/declaration/signature/inline/*.hs
31− , data/examples/declaration/signature/minimal/*.hs
28+ data/examples/declaration/signature/minimal/*.hs
32− , data/examples/declaration/signature/pattern/*.hs
29+ data/examples/declaration/signature/pattern/*.hs
33− , data/examples/declaration/signature/set-cost-centre/*.hs
30+ data/examples/declaration/signature/set-cost-centre/*.hs
34− , data/examples/declaration/signature/specialize/*.hs
31+ data/examples/declaration/signature/specialize/*.hs
35− , data/examples/declaration/signature/type/*.hs
32+ data/examples/declaration/signature/type/*.hs
36− , data/examples/declaration/splice/*.hs
33+ data/examples/declaration/splice/*.hs
37− , data/examples/declaration/type-families/closed-type-family/*.hs
34+ data/examples/declaration/type-families/closed-type-family/*.hs
38− , data/examples/declaration/type-families/data-family/*.hs
35+ data/examples/declaration/type-families/data-family/*.hs
39− , data/examples/declaration/type-families/type-family/*.hs
36+ data/examples/declaration/type-families/type-family/*.hs
40− , data/examples/declaration/type-synonyms/*.hs
37+ data/examples/declaration/type-synonyms/*.hs
41− , data/examples/declaration/type/*.hs
38+ data/examples/declaration/type/*.hs
42− , data/examples/declaration/value/function/*.hs
39+ data/examples/declaration/value/function/*.hs
43− , data/examples/declaration/value/function/arrow/*.hs
40+ data/examples/declaration/value/function/arrow/*.hs
44− , data/examples/declaration/value/function/comprehension/*.hs
41+ data/examples/declaration/value/function/comprehension/*.hs
45− , data/examples/declaration/value/function/do/*.hs
42+ data/examples/declaration/value/function/do/*.hs
46− , data/examples/declaration/value/function/infix/*.hs
43+ data/examples/declaration/value/function/infix/*.hs
47− , data/examples/declaration/value/function/pattern/*.hs
44+ data/examples/declaration/value/function/pattern/*.hs
48− , data/examples/declaration/value/other/*.hs
45+ data/examples/declaration/value/other/*.hs
49− , data/examples/declaration/value/pattern-synonyms/*.hs
46+ data/examples/declaration/value/pattern-synonyms/*.hs
50− , data/examples/declaration/warning/*.hs
47+ data/examples/declaration/warning/*.hs
51− , data/examples/import/*.hs
48+ data/examples/import/*.hs
52− , data/examples/module-header/*.hs
49+ data/examples/module-header/*.hs
53− , data/examples/other/*.hs
50+ data/examples/other/*.hs
51+
52+extra-doc-files:
53+ CONTRIBUTING.md
54+ CHANGELOG.md
55+ DESIGN.md
56+ README.md
54
57
55source-repository head
58source-repository head
56− type: git
59+ type: git
57− location: https://github.com/tweag/ormolu.git
60+ location: https://github.com/tweag/ormolu.git
58
61
59flag dev
62flag dev
60− description: Turn on development settings.
63+ description: Turn on development settings.
61− manual: True
62− default: False
64+ default: False
65+ manual: True
63
66
64library
67library
65− hs-source-dirs: src
66− build-depends: base >= 4.12 && < 5.0
67− , bytestring >= 0.2 && < 0.11
68− , containers >= 0.5 && < 0.7
69− , dlist >= 0.8 && < 0.9
70− , exceptions >= 0.6 && < 0.11
71− , ghc == 8.6.5
72− , ghc-boot-th == 8.6.5
73− , ghc-paths >= 0.1 && < 0.2
74− , mtl >= 2.0 && < 3.0
75− , syb >= 0.7 && < 0.8
76− , text >= 0.2 && < 1.3
77− exposed-modules: Ormolu
68+ exposed-modules:
69+ Ormolu
78− , Ormolu.Config
70+ Ormolu.Config
79− , Ormolu.Diff
71+ Ormolu.Diff
80− , Ormolu.Exception
72+ Ormolu.Exception
81− , Ormolu.Imports
73+ Ormolu.Imports
82− , Ormolu.Parser
74+ Ormolu.Parser
83− , Ormolu.Parser.Anns
75+ Ormolu.Parser.Anns
84− , Ormolu.Parser.CommentStream
76+ Ormolu.Parser.CommentStream
85− , Ormolu.Parser.Pragma
77+ Ormolu.Parser.Pragma
86− , Ormolu.Parser.Result
78+ Ormolu.Parser.Result
79+ Ormolu.Parser.Shebang
87− , Ormolu.Printer
80+ Ormolu.Printer
88− , Ormolu.Printer.Combinators
81+ Ormolu.Printer.Combinators
89− , Ormolu.Printer.Comments
82+ Ormolu.Printer.Comments
90− , Ormolu.Printer.Internal
83+ Ormolu.Printer.Internal
91− , Ormolu.Printer.Meat.Common
84+ Ormolu.Printer.Meat.Common
92− , Ormolu.Printer.Meat.Declaration
85+ Ormolu.Printer.Meat.Declaration
93− , Ormolu.Printer.Meat.Declaration.Annotation
86+ Ormolu.Printer.Meat.Declaration.Annotation
94− , Ormolu.Printer.Meat.Declaration.Class
87+ Ormolu.Printer.Meat.Declaration.Class
95− , Ormolu.Printer.Meat.Declaration.Data
88+ Ormolu.Printer.Meat.Declaration.Data
96− , Ormolu.Printer.Meat.Declaration.Default
89+ Ormolu.Printer.Meat.Declaration.Default
97− , Ormolu.Printer.Meat.Declaration.Foreign
90+ Ormolu.Printer.Meat.Declaration.Foreign
98− , Ormolu.Printer.Meat.Declaration.Instance
91+ Ormolu.Printer.Meat.Declaration.Instance
99− , Ormolu.Printer.Meat.Declaration.RoleAnnotation
92+ Ormolu.Printer.Meat.Declaration.RoleAnnotation
100− , Ormolu.Printer.Meat.Declaration.Rule
93+ Ormolu.Printer.Meat.Declaration.Rule
101− , Ormolu.Printer.Meat.Declaration.Signature
94+ Ormolu.Printer.Meat.Declaration.Signature
102− , Ormolu.Printer.Meat.Declaration.Splice
95+ Ormolu.Printer.Meat.Declaration.Splice
103− , Ormolu.Printer.Meat.Declaration.Type
96+ Ormolu.Printer.Meat.Declaration.Type
104− , Ormolu.Printer.Meat.Declaration.TypeFamily
97+ Ormolu.Printer.Meat.Declaration.TypeFamily
105− , Ormolu.Printer.Meat.Declaration.Value
98+ Ormolu.Printer.Meat.Declaration.Value
106− , Ormolu.Printer.Meat.Declaration.Warning
99+ Ormolu.Printer.Meat.Declaration.Warning
107− , Ormolu.Printer.Meat.ImportExport
100+ Ormolu.Printer.Meat.ImportExport
108− , Ormolu.Printer.Meat.Module
101+ Ormolu.Printer.Meat.Module
109− , Ormolu.Printer.Meat.Pragma
102+ Ormolu.Printer.Meat.Pragma
110− , Ormolu.Printer.Meat.Type
103+ Ormolu.Printer.Meat.Type
111− , Ormolu.Printer.Operators
104+ Ormolu.Printer.Operators
112− , Ormolu.Printer.SpanStream
105+ Ormolu.Printer.SpanStream
106+ Ormolu.Processing.Common
107+ Ormolu.Processing.Cpp
108+ Ormolu.Processing.Postprocess
109+ Ormolu.Processing.Preprocess
113− , Ormolu.Utils
110+ Ormolu.Utils
114− if flag(dev)
115− ghc-options: -Wall -Werror -Wcompat
116− -Wincomplete-record-updates
117− -Wincomplete-uni-patterns
118− -Wnoncanonical-monad-instances
119− -Wnoncanonical-monadfail-instances
120− else
121− ghc-options: -O2 -Wall
122− default-language: Haskell2010
123
111
124−test-suite tests
125− main-is: Spec.hs
126− hs-source-dirs: tests
112+ hs-source-dirs: src
127− type: exitcode-stdio-1.0
113+ other-modules:
114+ GHC
115+ GHC.DynFlags
116+
117+ default-language: Haskell2010
128− build-depends: base >= 4.12 && < 5.0
118+ build-depends:
119+ base >=4.12 && <5.0,
120+ bytestring >=0.2 && <0.11,
129− , containers >= 0.5 && < 0.7
121+ containers >=0.5 && <0.7,
130− , filepath >= 1.2 && < 1.5
122+ dlist >=0.8 && <2.0,
131− , hspec >= 2.0 && < 3.0
123+ exceptions >=0.6 && <0.11,
132− , ormolu
124+ ghc-lib-parser >=8.10 && <8.11,
133− , path >= 0.6 && < 0.7
125+ mtl >=2.0 && <3.0,
134− , path-io >= 1.4.2 && < 2.0
126+ syb >=0.7 && <0.8,
135− , text >= 0.2 && < 1.3
127+ text >=0.2 && <1.3
136− build-tools: hspec-discover >= 2.0 && < 3.0
137− other-modules:
138− Ormolu.Parser.PragmaSpec
139− , Ormolu.PrinterSpec
140
128
141− if flag(dev)
129+ if flag(dev)
142− ghc-options: -Wall -Werror
130+ ghc-options:
131+ -Wall -Werror -Wcompat -Wincomplete-record-updates
132+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances
133+ -Wno-missing-home-modules
134+
143− else
135+ else
144− ghc-options: -O2 -Wall
136+ ghc-options: -O2 -Wall
145− default-language: Haskell2010
146
137
147executable ormolu
138executable ormolu
148− main-is: Main.hs
139+ main-is: Main.hs
149− hs-source-dirs: app
140+ hs-source-dirs: app
141+ other-modules: Paths_ormolu
142+ default-language: Haskell2010
150− build-depends: base >= 4.12 && < 5.0
143+ build-depends:
151− , ghc == 8.6.5
144+ base >=4.12 && <5.0,
145+ ghc-lib-parser >=8.10 && <8.11,
152− , gitrev >= 1.3 && < 1.4
146+ gitrev >=1.3 && <1.4,
153− , optparse-applicative >= 0.14 && < 0.15
147+ optparse-applicative >=0.14 && <0.17,
154− , ormolu
148+ ormolu -any,
155− , text >= 0.2 && < 1.3
149+ text >=0.2 && <1.3
156− other-modules: Paths_ormolu
150+
157− if flag(dev)
151+ if flag(dev)
158− ghc-options: -Wall -Werror -Wcompat
152+ ghc-options:
159− -Wincomplete-record-updates
153+ -Wall -Werror -Wcompat -Wincomplete-record-updates
160− -Wincomplete-uni-patterns
161− -Wnoncanonical-monad-instances
154+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances
162− -Wnoncanonical-monadfail-instances
155+ -optP-Wno-nonportable-include-path
156+
163− else
157+ else
164− ghc-options: -O2 -Wall
158+ ghc-options: -O2 -Wall -rtsopts
159+
160+test-suite tests
161+ type: exitcode-stdio-1.0
162+ main-is: Spec.hs
163+ build-tools: hspec-discover >=2.0 && <3.0
164+ hs-source-dirs: tests
165+ other-modules:
166+ Ormolu.Parser.PragmaSpec
167+ Ormolu.PrinterSpec
168+
165− default-language: Haskell2010
169+ default-language: Haskell2010
170+ build-depends:
171+ base >=4.12 && <5.0,
172+ containers >=0.5 && <0.7,
173+ filepath >=1.2 && <1.5,
174+ hspec >=2.0 && <3.0,
175+ ormolu -any,
176+ path >=0.6 && <0.8,
177+ path-io >=1.4.2 && <2.0,
178+ text >=0.2 && <1.3
179+
180+ if flag(dev)
181+ ghc-options: -Wall -Werror
182+
183+ else
184+ ghc-options: -O2 -Wall
region-tests/expected-result-17-18.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo (
4+ foo, bar, baz) where
5+
6+foo :: Int
7+foo = 5
8+
9+bar :: Int -> Int
10+bar = \case
11+ 0 -> foo
12+ x -> x - foo
13+
14+baz :: Int -> Int
15+baz = gege
16+ where
17+ gege = 1 + 2
region-tests/expected-result-6-7.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo (
4+ foo, bar, baz) where
5+
6+foo :: Int
7+foo = 5
8+
9+bar :: Int -> Int
10+bar = \case
11+ 0 -> foo
12+ x -> x - foo
13+
14+baz :: Int -> Int
15+baz = gege
16+ where
17+ gege = 1 + 2
region-tests/expected-result-6-8.hsnew file+16
@@ -0,0 +1,16 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo (
4+ foo, bar, baz) where
5+
6+foo :: Int
7+foo = 5
8+bar :: Int -> Int
9+bar = \case
10+ 0 -> foo
11+ x -> x - foo
12+
13+baz :: Int -> Int
14+baz = gege
15+ where
16+ gege = 1 + 2
region-tests/expected-result-9-12.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo (
4+ foo, bar, baz) where
5+
6+foo :: Int
7+foo = 5
8+
9+bar :: Int -> Int
10+bar = \case
11+ 0 -> foo
12+ x -> x - foo
13+
14+baz :: Int -> Int
15+baz = gege
16+ where
17+ gege = 1 + 2
region-tests/expected-result-all.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo
4+ ( foo,
5+ bar,
6+ baz,
7+ )
8+where
9+
10+foo :: Int
11+foo = 5
12+
13+bar :: Int -> Int
14+bar = \case
15+ 0 -> foo
16+ x -> x - foo
17+
18+baz :: Int -> Int
19+baz = gege
20+ where
21+ gege = 1 + 2
region-tests/src.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+module Foo (
4+ foo, bar, baz) where
5+
6+foo :: Int
7+foo = 5
8+
9+bar :: Int -> Int
10+bar = \case
11+ 0 -> foo
12+ x -> x - foo
13+
14+baz :: Int -> Int
15+baz = gege
16+ where
17+ gege = 1 + 2
shell.nix+4−2
@@ -1,3 +1,5 @@
1−{ pkgs ? (import ./nix/nixpkgs) }:
1+{ pkgs ? (import ./nix/nixpkgs { inherit system; })
2+, system ? builtins.currentSystem
3+}:
2
4
3−(import ./default.nix { inherit pkgs; }).ormoluShell
5+(import ./default.nix { inherit pkgs; }).dev.ormoluShell
src/GHC.hsnew file+12
@@ -0,0 +1,12 @@
1+module GHC
2+ ( module X,
3+ )
4+where
5+
6+import ApiAnnotation as X
7+import BasicTypes as X
8+import GHC.Hs as X
9+import GHC.Hs.Instances as X ()
10+import Module as X
11+import RdrName as X
12+import SrcLoc as X
src/GHC/DynFlags.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# OPTIONS_GHC -Wno-missing-fields #-}
2+
3+-- Modified from ghc-lib-api-ext.
4+
5+module GHC.DynFlags
6+ ( baseDynFlags,
7+ )
8+where
9+
10+import Config
11+import DynFlags
12+import Fingerprint
13+import GHC.Platform
14+import ToolSettings
15+
16+fakeSettings :: Settings
17+fakeSettings =
18+ Settings
19+ { sGhcNameVersion =
20+ GhcNameVersion
21+ { ghcNameVersion_programName = "ghc",
22+ ghcNameVersion_projectVersion = cProjectVersion
23+ },
24+ sFileSettings = FileSettings {},
25+ sTargetPlatform =
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 =
37+ PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},
38+ sToolSettings =
39+ ToolSettings
40+ { toolSettings_opt_P_fingerprint = fingerprint0,
41+ toolSettings_pgm_F = ""
42+ }
43+ }
44+
45+fakeLlvmConfig :: LlvmConfig
46+fakeLlvmConfig = LlvmConfig [] []
47+
48+baseDynFlags :: DynFlags
49+baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
src/Ormolu.hs+19−19
@@ -1,5 +1,4 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE RecordWildCards #-}
3
2
4-- | A formatter for Haskell source code.
3-- | A formatter for Haskell source code.
5module Ormolu
4module Ormolu
@@ -7,6 +6,7 @@ module Ormolu
7 ormoluFile,
6 ormoluFile,
8 ormoluStdin,
7 ormoluStdin,
9 Config (..),
8 Config (..),
9+ RegionIndices (..),
10 defaultConfig,
10 defaultConfig,
11 DynOption (..),
11 DynOption (..),
12 OrmoluException (..),
12 OrmoluException (..),
@@ -29,7 +29,6 @@ import Ormolu.Parser.Result
29import Ormolu.Printer
29import Ormolu.Printer
30import Ormolu.Utils (showOutputable)
30import Ormolu.Utils (showOutputable)
31import qualified SrcLoc as GHC
31import qualified SrcLoc as GHC
32−import System.IO (hGetContents, stdin)
33
32
34-- | Format a 'String', return formatted version as 'Text'.
33-- | Format a 'String', return formatted version as 'Text'.
35--
34--
@@ -44,26 +43,27 @@ import System.IO (hGetContents, stdin)
44ormolu ::
43ormolu ::
45 MonadIO m =>
44 MonadIO m =>
46 -- | Ormolu configuration
45 -- | Ormolu configuration
47− Config ->
46+ Config RegionIndices ->
48 -- | Location of source file
47 -- | Location of source file
49 FilePath ->
48 FilePath ->
50 -- | Input to format
49 -- | Input to format
51 String ->
50 String ->
52 m Text
51 m Text
53−ormolu cfg path str = do
52+ormolu cfgWithIndices path str = do
53+ let totalLines = length (lines str)
54+ cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices
54− (ws, result0) <-
55+ (warnings, result0) <-
55 parseModule' cfg OrmoluParsingFailed path str
56 parseModule' cfg OrmoluParsingFailed path str
56 when (cfgDebug cfg) $ do
57 when (cfgDebug cfg) $ do
57 traceM "warnings:\n"
58 traceM "warnings:\n"
58− traceM (concatMap showWarn ws)
59+ traceM (concatMap showWarn warnings)
59 traceM (prettyPrintParseResult result0)
60 traceM (prettyPrintParseResult result0)
60− -- NOTE We're forcing 'txt' here because otherwise errors (such as
61+ -- We're forcing 'txt' here because otherwise errors (such as messages
61− -- messages about not-yet-supported functionality) will be thrown later
62+ -- about not-yet-supported functionality) will be thrown later when we try
62− -- when we try to parse the rendered code back, inside of GHC monad
63+ -- to parse the rendered code back, inside of GHC monad wrapper which will
63− -- wrapper which will lead to error messages presenting the exceptions as
64+ -- lead to error messages presenting the exceptions as GHC bugs.
64− -- GHC bugs.
65 let !txt = printModule result0
65 let !txt = printModule result0
66− when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do
66+ when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do
67 let pathRendered = path ++ "<rendered>"
67 let pathRendered = path ++ "<rendered>"
68 -- Parse the result of pretty-printing again and make sure that AST
68 -- Parse the result of pretty-printing again and make sure that AST
69 -- is the same as AST of original snippet module span positions.
69 -- is the same as AST of original snippet module span positions.
@@ -79,7 +79,7 @@ ormolu cfg path str = do
79 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)
79 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)
80 -- Try re-formatting the formatted result to check if we get exactly
80 -- Try re-formatting the formatted result to check if we get exactly
81 -- the same output.
81 -- the same output.
82− when (cfgCheckIdempotency cfg) $
82+ when (cfgCheckIdempotence cfg) $
83 let txt2 = printModule result1
83 let txt2 = printModule result1
84 in case diffText txt txt2 pathRendered of
84 in case diffText txt txt2 pathRendered of
85 Nothing -> return ()
85 Nothing -> return ()
@@ -96,7 +96,7 @@ ormolu cfg path str = do
96ormoluFile ::
96ormoluFile ::
97 MonadIO m =>
97 MonadIO m =>
98 -- | Ormolu configuration
98 -- | Ormolu configuration
99− Config ->
99+ Config RegionIndices ->
100 -- | Location of source file
100 -- | Location of source file
101 FilePath ->
101 FilePath ->
102 -- | Resulting rendition
102 -- | Resulting rendition
@@ -111,11 +111,11 @@ ormoluFile cfg path =
111ormoluStdin ::
111ormoluStdin ::
112 MonadIO m =>
112 MonadIO m =>
113 -- | Ormolu configuration
113 -- | Ormolu configuration
114− Config ->
114+ Config RegionIndices ->
115 -- | Resulting rendition
115 -- | Resulting rendition
116 m Text
116 m Text
117ormoluStdin cfg =
117ormoluStdin cfg =
118− liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
118+ liftIO getContents >>= ormolu cfg "<stdin>"
119
119
120----------------------------------------------------------------------------
120----------------------------------------------------------------------------
121-- Helpers
121-- Helpers
@@ -124,7 +124,7 @@ ormoluStdin cfg =
124parseModule' ::
124parseModule' ::
125 MonadIO m =>
125 MonadIO m =>
126 -- | Ormolu configuration
126 -- | Ormolu configuration
127− Config ->
127+ Config RegionDeltas ->
128 -- | How to obtain 'OrmoluException' to throw when parsing fails
128 -- | How to obtain 'OrmoluException' to throw when parsing fails
129 (GHC.SrcSpan -> String -> OrmoluException) ->
129 (GHC.SrcSpan -> String -> OrmoluException) ->
130 -- | File name to use in errors
130 -- | File name to use in errors
@@ -133,10 +133,10 @@ parseModule' ::
133 String ->
133 String ->
134 m ([GHC.Warn], ParseResult)
134 m ([GHC.Warn], ParseResult)
135parseModule' cfg mkException path str = do
135parseModule' cfg mkException path str = do
136− (ws, r) <- parseModule cfg path str
136+ (warnings, r) <- parseModule cfg path str
137 case r of
137 case r of
138 Left (spn, err) -> liftIO $ throwIO (mkException spn err)
138 Left (spn, err) -> liftIO $ throwIO (mkException spn err)
139− Right x -> return (ws, x)
139+ Right x -> return (warnings, x)
140
140
141-- | Pretty-print a 'GHC.Warn'.
141-- | Pretty-print a 'GHC.Warn'.
142showWarn :: GHC.Warn -> String
142showWarn :: GHC.Warn -> String
src/Ormolu/Config.hs+65−29
@@ -1,11 +1,13 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
4
3
5-- | Configuration options used by the tool.
4-- | Configuration options used by the tool.
6module Ormolu.Config
5module Ormolu.Config
7 ( Config (..),
6 ( Config (..),
7+ RegionIndices (..),
8+ RegionDeltas (..),
8 defaultConfig,
9 defaultConfig,
10+ regionIndicesToDeltas,
9 DynOption (..),
11 DynOption (..),
10 dynOptionToLocatedStr,
12 dynOptionToLocatedStr,
11 )
13 )
@@ -14,38 +16,72 @@ where
14import qualified SrcLoc as GHC
16import qualified SrcLoc as GHC
15
17
16-- | Ormolu configuration.
18-- | Ormolu configuration.
17−data Config
19+data Config region = Config
18− = Config
19− { -- | Dynamic options to pass to GHC parser
20+ { -- | Dynamic options to pass to GHC parser
20− cfgDynOptions :: ![DynOption],
21+ cfgDynOptions :: ![DynOption],
21− -- | Do formatting faster but without automatic detection of defects
22+ -- | Do formatting faster but without automatic detection of defects
22− cfgUnsafe :: !Bool,
23+ cfgUnsafe :: !Bool,
23− -- | Output information useful for debugging
24+ -- | Output information useful for debugging
24− cfgDebug :: !Bool,
25+ cfgDebug :: !Bool,
25− -- | Do not fail if CPP pragma is present (still doesn't handle CPP but
26− -- useful for formatting of files that enable the extension without
27− -- actually containing CPP macros)
28− cfgTolerateCpp :: !Bool,
29− -- | Checks if re-formatting the result is idempotent.
26+ -- | Checks if re-formatting the result is idempotent
30− cfgCheckIdempotency :: !Bool
27+ cfgCheckIdempotence :: !Bool,
28+ -- | Region selection
29+ cfgRegion :: !region
30+ }
31+ deriving (Eq, Show, Functor)
32+
33+-- | Region selection as the combination of start and end line numbers.
34+data RegionIndices = RegionIndices
35+ { -- | Start line of the region to format
36+ regionStartLine :: !(Maybe Int),
37+ -- | End line of the region to format
38+ regionEndLine :: !(Maybe Int)
31− }
39+ }
32 deriving (Eq, Show)
40 deriving (Eq, Show)
33
41
34−-- | Default 'Config'.
42+-- | Region selection as the length of the literal prefix and the literal
35−defaultConfig :: Config
43+-- suffix.
36−defaultConfig = Config
44+data RegionDeltas = RegionDeltas
37− { cfgDynOptions = [],
45+ { -- | Prefix length in number of lines
38− cfgUnsafe = False,
46+ regionPrefixLength :: !Int,
39− cfgDebug = False,
47+ -- | Suffix length in number of lines
40− cfgTolerateCpp = False,
48+ regionSuffixLength :: !Int
41− cfgCheckIdempotency = False
42 }
49 }
50+ deriving (Eq, Show)
51+
52+-- | Default @'Config' 'RegionIndices'@.
53+defaultConfig :: Config RegionIndices
54+defaultConfig =
55+ Config
56+ { cfgDynOptions = [],
57+ cfgUnsafe = False,
58+ cfgDebug = False,
59+ cfgCheckIdempotence = False,
60+ cfgRegion =
61+ RegionIndices
62+ { regionStartLine = Nothing,
63+ regionEndLine = Nothing
64+ }
65+ }
66+
67+-- | Convert 'RegionIndices' into 'RegionDeltas'.
68+regionIndicesToDeltas ::
69+ -- | Total number of lines in the input
70+ Int ->
71+ -- | Region indices
72+ RegionIndices ->
73+ -- | Region deltas
74+ RegionDeltas
75+regionIndicesToDeltas total RegionIndices {..} =
76+ RegionDeltas
77+ { regionPrefixLength = maybe 0 (subtract 1) regionStartLine,
78+ regionSuffixLength = maybe 0 (total -) regionEndLine
79+ }
43
80
44-- | A wrapper for dynamic options.
81-- | A wrapper for dynamic options.
45−newtype DynOption
82+newtype DynOption = DynOption
46− = DynOption
47− { unDynOption :: String
83+ { unDynOption :: String
48− }
84+ }
49 deriving (Eq, Ord, Show)
85 deriving (Eq, Ord, Show)
50
86
51-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
87-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
src/Ormolu/Diff.hs+25−18
@@ -1,6 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE RecordWildCards #-}
4
2
5-- | Diffing GHC ASTs modulo span positions.
3-- | Diffing GHC ASTs modulo span positions.
6module Ormolu.Diff
4module Ormolu.Diff
@@ -10,17 +8,16 @@ module Ormolu.Diff
10 )
8 )
11where
9where
12
10
13−import BasicTypes (SourceText)
14import Data.ByteString (ByteString)
11import Data.ByteString (ByteString)
15import Data.Generics
12import Data.Generics
16import Data.Text (Text)
13import Data.Text (Text)
17import qualified Data.Text as T
14import qualified Data.Text as T
18import qualified FastString as GHC
15import qualified FastString as GHC
19import GHC
16import GHC
20−import Ormolu.Imports (sortImports)
17+import Ormolu.Imports (normalizeImports)
18+import Ormolu.Parser.CommentStream
21import Ormolu.Parser.Result
19import Ormolu.Parser.Result
22import Ormolu.Utils
20import Ormolu.Utils
23−import qualified SrcLoc as GHC
24
21
25-- | Result of comparing two 'ParseResult's.
22-- | Result of comparing two 'ParseResult's.
26data Diff
23data Diff
@@ -42,14 +39,16 @@ diffParseResult :: ParseResult -> ParseResult -> Diff
42diffParseResult
39diffParseResult
43 ParseResult
40 ParseResult
44 { prCommentStream = cstream0,
41 { prCommentStream = cstream0,
45− prParsedSource = ps0
42+ prParsedSource = hs0
46 }
43 }
47 ParseResult
44 ParseResult
48 { prCommentStream = cstream1,
45 { prCommentStream = cstream1,
49− prParsedSource = ps1
46+ prParsedSource = hs1
50 } =
47 } =
51 matchIgnoringSrcSpans cstream0 cstream1
48 matchIgnoringSrcSpans cstream0 cstream1
52− <> matchIgnoringSrcSpans ps0 ps1
49+ <> matchIgnoringSrcSpans
50+ hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}
51+ hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}
53
52
54-- | Compare two values for equality disregarding differences in 'SrcSpan's
53-- | Compare two values for equality disregarding differences in 'SrcSpan's
55-- and the ordering of import lists.
54-- and the ordering of import lists.
@@ -58,7 +57,7 @@ matchIgnoringSrcSpans = genericQuery
58 where
57 where
59 genericQuery :: GenericQ (GenericQ Diff)
58 genericQuery :: GenericQ (GenericQ Diff)
60 genericQuery x y
59 genericQuery x y
61− -- NOTE 'ByteString' implement 'Data' instance manually and does not
60+ -- 'ByteString' implements 'Data' instance manually and does not
62 -- implement 'toConstr', so we have to deal with it in a special way.
61 -- implement 'toConstr', so we have to deal with it in a special way.
63 | Just x' <- cast x,
62 | Just x' <- cast x,
64 Just y' <- cast y =
63 Just y' <- cast y =
@@ -71,9 +70,10 @@ matchIgnoringSrcSpans = genericQuery
71 gzipWithQ
70 gzipWithQ
72 ( genericQuery
71 ( genericQuery
73 `extQ` srcSpanEq
72 `extQ` srcSpanEq
74− `extQ` hsModuleEq
73+ `extQ` commentEq
75 `extQ` sourceTextEq
74 `extQ` sourceTextEq
76 `extQ` hsDocStringEq
75 `extQ` hsDocStringEq
76+ `extQ` importDeclQualifiedStyleEq
77 `ext2Q` forLocated
77 `ext2Q` forLocated
78 )
78 )
79 x
79 x
@@ -81,16 +81,23 @@ matchIgnoringSrcSpans = genericQuery
81 | otherwise = Different []
81 | otherwise = Different []
82 srcSpanEq :: SrcSpan -> GenericQ Diff
82 srcSpanEq :: SrcSpan -> GenericQ Diff
83 srcSpanEq _ _ = Same
83 srcSpanEq _ _ = Same
84− hsModuleEq :: HsModule GhcPs -> GenericQ Diff
84+ commentEq :: Comment -> GenericQ Diff
85− hsModuleEq hs0 hs1' =
85+ commentEq (Comment _ x) d =
86− case cast hs1' :: Maybe (HsModule GhcPs) of
86+ case cast d :: Maybe Comment of
87 Nothing -> Different []
87 Nothing -> Different []
88− Just hs1 ->
88+ Just (Comment _ y) ->
89− matchIgnoringSrcSpans
89+ if x == y
90− hs0 {hsmodImports = sortImports (hsmodImports hs0)}
90+ then Same
91− hs1 {hsmodImports = sortImports (hsmodImports hs1)}
91+ else Different []
92 sourceTextEq :: SourceText -> GenericQ Diff
92 sourceTextEq :: SourceText -> GenericQ Diff
93 sourceTextEq _ _ = Same
93 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 []
94 hsDocStringEq :: HsDocString -> GenericQ Diff
101 hsDocStringEq :: HsDocString -> GenericQ Diff
95 hsDocStringEq str0 str1' =
102 hsDocStringEq str0 str1' =
96 case cast str1' :: Maybe HsDocString of
103 case cast str1' :: Maybe HsDocString of
@@ -108,7 +115,7 @@ matchIgnoringSrcSpans = genericQuery
108 appendSpan :: SrcSpan -> Diff -> Diff
115 appendSpan :: SrcSpan -> Diff -> Diff
109 appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
116 appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
110 where
117 where
111− fresh = not $ any (flip isSubspanOf s) ss
118+ fresh = not $ any (`isSubspanOf` s) ss
112 helpful = isGoodSrcSpan s
119 helpful = isGoodSrcSpan s
113 appendSpan _ d = d
120 appendSpan _ d = d
114
121
src/Ormolu/Exception.hs+27−20
@@ -8,6 +8,8 @@ module Ormolu.Exception
8where
8where
9
9
10import Control.Exception
10import Control.Exception
11+import Data.List.NonEmpty (NonEmpty (..))
12+import qualified Data.List.NonEmpty as NE
11import Data.Text (Text)
13import Data.Text (Text)
12import qualified GHC
14import qualified GHC
13import Ormolu.Utils (showOutputable)
15import Ormolu.Utils (showOutputable)
@@ -17,9 +19,7 @@ import System.IO
17
19
18-- | Ormolu exception representing all cases when Ormolu can fail.
20-- | Ormolu exception representing all cases when Ormolu can fail.
19data OrmoluException
21data OrmoluException
20− = -- | Ormolu does not work with source files that use CPP
21− OrmoluCppEnabled FilePath
22− | -- | Parsing of original source code failed
22+ = -- | Parsing of original source code failed
23 OrmoluParsingFailed GHC.SrcSpan String
23 OrmoluParsingFailed GHC.SrcSpan String
24 | -- | Parsing of formatted source code failed
24 | -- | Parsing of formatted source code failed
25 OrmoluOutputParsingFailed GHC.SrcSpan String
25 OrmoluOutputParsingFailed GHC.SrcSpan String
@@ -27,17 +27,14 @@ data OrmoluException
27 OrmoluASTDiffers FilePath [GHC.SrcSpan]
27 OrmoluASTDiffers FilePath [GHC.SrcSpan]
28 | -- | Formatted source code is not idempotent
28 | -- | Formatted source code is not idempotent
29 OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
29 OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
30+ | -- | Some GHC options were not recognized
31+ OrmoluUnrecognizedOpts (NonEmpty String)
30 deriving (Eq, Show)
32 deriving (Eq, Show)
31
33
32instance Exception OrmoluException where
34instance Exception OrmoluException where
33 displayException = \case
35 displayException = \case
34− OrmoluCppEnabled path ->
35− unlines
36− [ "CPP is not supported:",
37− withIndent path
38− ]
39 OrmoluParsingFailed s e ->
36 OrmoluParsingFailed s e ->
40− showParsingErr "Parsing of source code failed:" s [e]
37+ showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]
41 OrmoluOutputParsingFailed s e ->
38 OrmoluOutputParsingFailed s e ->
42 showParsingErr "Parsing of formatted code failed:" s [e]
39 showParsingErr "Parsing of formatted code failed:" s [e]
43 ++ "Please, consider reporting the bug.\n"
40 ++ "Please, consider reporting the bug.\n"
@@ -45,15 +42,24 @@ instance Exception OrmoluException where
45 unlines $
42 unlines $
46 [ "AST of input and AST of formatted code differ."
43 [ "AST of input and AST of formatted code differ."
47 ]
44 ]
45+ ++ fmap
46+ withIndent
48− ++ ( fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of
47+ ( case fmap (\s -> "at " ++ showOutputable s) ss of
49− [] -> ["in " ++ path]
48+ [] -> ["in " ++ path]
50− xs -> xs
49+ xs -> xs
51− )
50+ )
52 ++ ["Please, consider reporting the bug."]
51 ++ ["Please, consider reporting the bug."]
53 OrmoluNonIdempotentOutput loc left right ->
52 OrmoluNonIdempotentOutput loc left right ->
53+ showParsingErr
54− showParsingErr "Formatting is not idempotent:" loc
54+ "Formatting is not idempotent:"
55+ loc
55 ["before: " ++ show left, "after: " ++ show right]
56 ["before: " ++ show left, "after: " ++ show right]
56 ++ "Please, consider reporting the bug.\n"
57 ++ "Please, consider reporting the bug.\n"
58+ OrmoluUnrecognizedOpts opts ->
59+ unlines
60+ [ "The following GHC options were not recognized:",
61+ (withIndent . unwords . NE.toList) opts
62+ ]
57
63
58-- | Inside this wrapper 'OrmoluException' will be caught and displayed
64-- | Inside this wrapper 'OrmoluException' will be caught and displayed
59-- nicely using 'displayException'.
65-- nicely using 'displayException'.
@@ -68,12 +74,13 @@ withPrettyOrmoluExceptions m = m `catch` h
68 hPutStrLn stderr (displayException e)
74 hPutStrLn stderr (displayException e)
69 exitWith . ExitFailure $
75 exitWith . ExitFailure $
70 case e of
76 case e of
71− -- Error code 1 is for `error` or `notImplemented`
77+ -- Error code 1 is for 'error' or 'notImplemented'
72− OrmoluCppEnabled _ -> 2
78+ -- 2 used to be for erroring out on CPP
73− OrmoluParsingFailed _ _ -> 3
79+ OrmoluParsingFailed {} -> 3
74− OrmoluOutputParsingFailed _ _ -> 4
80+ OrmoluOutputParsingFailed {} -> 4
75− OrmoluASTDiffers _ _ -> 5
81+ OrmoluASTDiffers {} -> 5
76− OrmoluNonIdempotentOutput _ _ _ -> 6
82+ OrmoluNonIdempotentOutput {} -> 6
83+ OrmoluUnrecognizedOpts {} -> 7
77
84
78----------------------------------------------------------------------------
85----------------------------------------------------------------------------
79-- Helpers
86-- Helpers
src/Ormolu/Imports.hs+172−51
@@ -1,81 +1,202 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
3
4
4-- | Manipulations on import lists.
5-- | Manipulations on import lists.
5module Ormolu.Imports
6module Ormolu.Imports
6− ( sortImports,
7+ ( normalizeImports,
7 )
8 )
8where
9where
9
10
10import Data.Bifunctor
11import Data.Bifunctor
12+import Data.Char (isAlphaNum)
11import Data.Function (on)
13import Data.Function (on)
12−import Data.Generics (gcompare)
14+import Data.List (foldl', nubBy, sortBy, sortOn)
13−import Data.List (sortBy)
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
17+import FastString (FastString)
14import GHC hiding (GhcPs, IE)
18import GHC hiding (GhcPs, IE)
15−import HsExtension
19+import GHC.Hs.Extension
16−import HsImpExp (IE (..))
20+import GHC.Hs.ImpExp (IE (..))
17−import Ormolu.Utils (notImplemented)
21+import Ormolu.Utils (notImplemented, showOutputable)
18
22
19−-- | Sort imports by module name. This also sorts explicit import lists for
23+-- | Sort and normalize imports.
20−-- each declaration.
21−sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
24+normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
22−sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
25+normalizeImports =
26+ fmap snd
27+ . M.toAscList
28+ . M.fromListWith combineImports
29+ . fmap (\x -> (importId x, g x))
23 where
30 where
24− sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
31+ g (L l ImportDecl {..}) =
25− sortImportLists decl =
32+ L
26− decl
33+ l
34+ ImportDecl
27− { ideclHiding = second (fmap sortLies) <$> ideclHiding decl
35+ { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,
36+ ..
28− }
37+ }
38+ g _ = notImplemented "XImportDecl"
29
39
40+-- | Combine two import declarations. It should be assumed that 'ImportId's
41+-- are equal.
42+combineImports ::
30−-- | Compare two @'LImportDecl' 'GhcPs'@ things.
43+ LImportDecl GhcPs ->
31−compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
44+ LImportDecl GhcPs ->
32−compareIdecl (L _ m0) (L _ m1) =
45+ LImportDecl GhcPs
33− case (isPrelude n0, isPrelude n1) of
46+combineImports (L lx ImportDecl {..}) (L _ y) =
34− (False, False) -> n0 `compare` n1
47+ L
35− (True, False) -> GT
48+ lx
36− (False, True) -> LT
49+ ImportDecl
37− (True, True) -> m0 `gcompare` m1
50+ { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of
51+ (Just (hiding, L l' xs), Just (_, L _ ys)) ->
52+ Just (hiding, (L l' (normalizeLies (xs ++ ys))))
53+ _ -> Nothing,
54+ ..
55+ }
56+combineImports _ _ = notImplemented "XImportDecl"
57+
58+-- | Import id, a collection of all things that justify having a separate
59+-- import entry. This is used for merging of imports. If two imports have
60+-- the same 'ImportId' they can be merged.
61+data ImportId = ImportId
62+ { importIsPrelude :: Bool,
63+ importIdName :: ModuleName,
64+ importPkgQual :: Maybe FastString,
65+ importSource :: Bool,
66+ importSafe :: Bool,
67+ importQualified :: Bool,
68+ importImplicit :: Bool,
69+ importAs :: Maybe ModuleName,
70+ importHiding :: Maybe Bool
71+ }
72+ deriving (Eq, Ord)
73+
74+-- | Obtain an 'ImportId' for a given import.
75+importId :: LImportDecl GhcPs -> ImportId
76+importId (L _ ImportDecl {..}) =
77+ ImportId
78+ { importIsPrelude = isPrelude,
79+ importIdName = moduleName,
80+ importPkgQual = sl_fs <$> ideclPkgQual,
81+ importSource = ideclSource,
82+ importSafe = ideclSafe,
83+ importQualified = case ideclQualified of
84+ QualifiedPre -> True
85+ QualifiedPost -> True
86+ NotQualified -> False,
87+ importImplicit = ideclImplicit,
88+ importAs = unLoc <$> ideclAs,
89+ importHiding = fst <$> ideclHiding
90+ }
38 where
91 where
39− n0 = unLoc (ideclName m0)
40− n1 = unLoc (ideclName m1)
41− isPrelude = (== "Prelude") . moduleNameString
92+ isPrelude = moduleNameString moduleName == "Prelude"
93+ moduleName = unLoc ideclName
94+importId _ = notImplemented "XImportDecl"
42
95
43−-- | Sort located import or export.
96+-- | Normalize a collection of import\/export items.
44−sortLies :: [LIE GhcPs] -> [LIE GhcPs]
97+normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]
45−sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
98+normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty
99+ where
100+ combine ::
101+ Map IEWrappedNameOrd (LIE GhcPs) ->
102+ LIE GhcPs ->
103+ Map IEWrappedNameOrd (LIE GhcPs)
104+ combine m (L new_l new) =
105+ let wname = getIewn new
106+ normalizeWNames =
107+ nubBy (\x y -> compareLIewn x y == EQ) . sortBy compareLIewn
108+ alter = \case
109+ Nothing -> Just . L new_l $
110+ case new of
111+ IEThingWith NoExtField n wildcard g flbl ->
112+ IEThingWith NoExtField n wildcard (normalizeWNames g) flbl
113+ other -> other
114+ Just old ->
115+ let f = \case
116+ IEVar NoExtField n -> IEVar NoExtField n
117+ IEThingAbs NoExtField _ -> new
118+ IEThingAll NoExtField n -> IEThingAll NoExtField n
119+ IEThingWith NoExtField n wildcard g flbl ->
120+ case new of
121+ IEVar NoExtField _ ->
122+ error "Ormolu.Imports broken presupposition"
123+ IEThingAbs NoExtField _ ->
124+ IEThingWith NoExtField n wildcard g flbl
125+ IEThingAll NoExtField n' ->
126+ IEThingAll NoExtField n'
127+ IEThingWith NoExtField n' wildcard' g' flbl' ->
128+ let combinedWildcard =
129+ case (wildcard, wildcard') of
130+ (IEWildcard _, _) -> IEWildcard 0
131+ (_, IEWildcard _) -> IEWildcard 0
132+ _ -> NoIEWildcard
133+ in IEThingWith
134+ NoExtField
135+ n'
136+ combinedWildcard
137+ (normalizeWNames (g <> g'))
138+ flbl'
139+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
140+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
141+ IEDoc NoExtField _ -> notImplemented "IEDoc"
142+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
143+ XIE x -> noExtCon x
144+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
145+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
146+ IEDoc NoExtField _ -> notImplemented "IEDoc"
147+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
148+ XIE x -> noExtCon x
149+ in Just (f <$> old)
150+ in M.alter alter wname m
46
151
47−-- | Sort imports\/exports inside of 'IEThingWith'.
152+-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an
48−sortThings :: IE GhcPs -> IE GhcPs
153+-- 'Ord' instance for it.
49−sortThings = \case
154+newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName)
50− IEThingWith NoExt x w xs fl ->
155+ deriving (Eq)
51− IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl
52− other -> other
53
156
54−-- | Compare two located imports or exports.
157+instance Ord IEWrappedNameOrd where
55−compareIE :: IE GhcPs -> IE GhcPs -> Ordering
158+ compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y
56−compareIE = compareIewn `on` getIewn
57
159
58-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
160-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
59−getIewn :: IE GhcPs -> IEWrappedName RdrName
161+getIewn :: IE GhcPs -> IEWrappedNameOrd
60getIewn = \case
162getIewn = \case
61− IEVar NoExt x -> unLoc x
163+ IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)
62− IEThingAbs NoExt x -> unLoc x
164+ IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)
63− IEThingAll NoExt x -> unLoc x
165+ IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)
64− IEThingWith NoExt x _ _ _ -> unLoc x
166+ IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)
65− IEModuleContents NoExt _ -> notImplemented "IEModuleContents"
167+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
66− IEGroup NoExt _ _ -> notImplemented "IEGroup"
168+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
67− IEDoc NoExt _ -> notImplemented "IEDoc"
169+ IEDoc NoExtField _ -> notImplemented "IEDoc"
68− IEDocNamed NoExt _ -> notImplemented "IEDocNamed"
170+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
69− XIE NoExt -> notImplemented "XIE"
171+ XIE x -> noExtCon x
172+
173+-- | Like 'compareIewn' for located wrapped names.
174+compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering
175+compareLIewn = compareIewn `on` unLoc
70
176
71-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
177-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
72compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
178compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
73−compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y
179+compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y
74compareIewn (IEName _) (IEPattern _) = LT
180compareIewn (IEName _) (IEPattern _) = LT
75compareIewn (IEName _) (IEType _) = LT
181compareIewn (IEName _) (IEType _) = LT
76compareIewn (IEPattern _) (IEName _) = GT
182compareIewn (IEPattern _) (IEName _) = GT
77−compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y
183+compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y
78compareIewn (IEPattern _) (IEType _) = LT
184compareIewn (IEPattern _) (IEType _) = LT
79compareIewn (IEType _) (IEName _) = GT
185compareIewn (IEType _) (IEName _) = GT
80compareIewn (IEType _) (IEPattern _) = GT
186compareIewn (IEType _) (IEPattern _) = GT
81−compareIewn (IEType x) (IEType y) = unLoc x `compare` unLoc y
187+compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y
188+
189+compareRdrName :: RdrName -> RdrName -> Ordering
190+compareRdrName x y =
191+ case (getNameStr x, getNameStr y) of
192+ ([], []) -> EQ
193+ ((_ : _), []) -> GT
194+ ([], (_ : _)) -> LT
195+ ((x' : _), (y' : _)) ->
196+ case (isAlphaNum x', isAlphaNum y') of
197+ (False, False) -> x `compare` y
198+ (True, False) -> LT
199+ (False, True) -> GT
200+ (True, True) -> x `compare` y
201+ where
202+ getNameStr = showOutputable . rdrNameOcc
src/Ormolu/Parser.hs+135−117
@@ -1,5 +1,5 @@
1+{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
4
4
5-- | Parser for Haskell source code.
5-- | Parser for Haskell source code.
@@ -9,34 +9,39 @@ module Ormolu.Parser
9 )
9 )
10where
10where
11
11
12+import Bag (bagToList)
12import qualified CmdLineParser as GHC
13import qualified CmdLineParser as GHC
13import Control.Exception
14import Control.Exception
14−import Control.Monad
15import Control.Monad.IO.Class
15import Control.Monad.IO.Class
16−import Data.List ((\\), foldl', isPrefixOf)
16+import qualified Data.List as L
17+import qualified Data.List.NonEmpty as NE
17−import Data.Maybe (catMaybes)
18+import Data.Ord (Down (Down))
18−import qualified DynFlags as GHC
19+import qualified Data.Text as T
20+import DynFlags as GHC
21+import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
19import qualified FastString as GHC
22import qualified FastString as GHC
20−import GHC hiding (IE, parseModule, parser)
23+import GHC hiding (IE, UnicodeSyntax)
24+import GHC.DynFlags (baseDynFlags)
21import GHC.LanguageExtensions.Type (Extension (..))
25import GHC.LanguageExtensions.Type (Extension (..))
22−import GHC.Paths (libdir)
23import qualified HeaderInfo as GHC
26import qualified HeaderInfo as GHC
27+import qualified HscTypes as GHC
24import qualified Lexer as GHC
28import qualified Lexer as GHC
25import Ormolu.Config
29import Ormolu.Config
26import Ormolu.Exception
30import Ormolu.Exception
27import Ormolu.Parser.Anns
31import Ormolu.Parser.Anns
28import Ormolu.Parser.CommentStream
32import Ormolu.Parser.CommentStream
29import Ormolu.Parser.Result
33import Ormolu.Parser.Result
34+import Ormolu.Processing.Preprocess (preprocess)
35+import Ormolu.Utils (incSpanLine, removeIndentation)
30−import qualified Outputable as GHC
36+import qualified Panic as GHC
31import qualified Parser as GHC
37import qualified Parser as GHC
32−import qualified SrcLoc as GHC
33import qualified StringBuffer as GHC
38import qualified StringBuffer as GHC
34
39
35-- | Parse a complete module from string.
40-- | Parse a complete module from string.
36parseModule ::
41parseModule ::
37 MonadIO m =>
42 MonadIO m =>
38 -- | Ormolu configuration
43 -- | Ormolu configuration
39− Config ->
44+ Config RegionDeltas ->
40 -- | File name (only for source location annotations)
45 -- | File name (only for source location annotations)
41 FilePath ->
46 FilePath ->
42 -- | Input for parser
47 -- | Input for parser
@@ -45,32 +50,79 @@ parseModule ::
45 ( [GHC.Warn],
50 ( [GHC.Warn],
46 Either (SrcSpan, String) ParseResult
51 Either (SrcSpan, String) ParseResult
47 )
52 )
48−parseModule Config {..} path input' = liftIO $ do
53+parseModule Config {..} path rawInput = liftIO $ do
49− let (input, extraComments) = stripLinePragmas path input'
54+ let (literalPrefix, indentedInput, literalSuffix, extraComments) =
50− (ws, dynFlags) <- ghcWrapper $ do
55+ preprocess path rawInput cfgRegion
51− dynFlags0 <- initDynFlagsPure path input
56+ (input, indent) = removeIndentation indentedInput
52− (dynFlags1, _, ws) <-
57+ -- It's important that 'setDefaultExts' is done before
53− GHC.parseDynamicFilePragma
58+ -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
54− dynFlags0
59+ -- extension that was explicitly disabled in the file.
55− (dynOptionToLocatedStr <$> cfgDynOptions)
60+ let baseFlags =
56− return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
61+ GHC.setGeneralFlag'
57− -- NOTE It's better to throw this outside of 'ghcWrapper' because
62+ GHC.Opt_Haddock
58− -- otherwise the exception will be wrapped as a GHC panic, which we don't
63+ (setDefaultExts baseDynFlags)
59− -- want.
64+ extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
60− when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
65+ (warnings, dynFlags) <-
61− throwIO (OrmoluCppEnabled path)
66+ parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case
67+ Right res -> pure res
68+ Left err ->
69+ let loc =
70+ mkSrcSpan
71+ (mkSrcLoc (GHC.mkFastString path) 1 1)
72+ (mkSrcLoc (GHC.mkFastString path) 1 1)
73+ in throwIO (OrmoluParsingFailed loc err)
74+ let useRecordDot =
75+ "record-dot-preprocessor" == pgm_F dynFlags
76+ || any
77+ (("RecordDotPreprocessor" ==) . moduleNameString)
78+ (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)
62− let r = case runParser GHC.parseModule dynFlags path input of
87+ r = case runParser GHC.parseModule dynFlags path input of
63− GHC.PFailed _ ss m ->
88+ GHC.PFailed pstate ->
64− Left (ss, GHC.showSDoc dynFlags m)
89+ case pStateErrors pstate of
90+ Just err -> Left err
91+ Nothing -> error "PFailed does not have an error"
65− GHC.POk pstate pmod ->
92+ GHC.POk pstate (L _ hsModule) ->
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) =
66− let (comments, exts) = mkCommentStream extraComments pstate
101+ mkCommentStream input extraComments pstate
102+ in Right
67− in Right ParseResult
103+ ParseResult
68− { prParsedSource = pmod,
104+ { prParsedSource = hsModule,
69− prAnns = mkAnns pstate,
105+ prAnns = mkAnns pstate,
106+ prStackHeader = stackHeader,
107+ prShebangs = shebangs,
108+ prPragmas = pragmas,
70− prCommentStream = comments,
109+ prCommentStream = comments,
71− prExtensions = exts
110+ prUseRecordDot = useRecordDot,
111+ prImportQualifiedPost =
112+ GHC.xopt ImportQualifiedPost dynFlags,
113+ prLiteralPrefix = T.pack literalPrefix,
114+ prLiteralSuffix = T.pack literalSuffix,
115+ prIndent = indent
72− }
116+ }
73− return (ws, r)
117+ return (warnings, r)
118+
119+-- | Enable all language extensions that we think should be enabled by
120+-- default for ease of use.
121+setDefaultExts :: DynFlags -> DynFlags
122+setDefaultExts flags = L.foldl' xopt_set flags autoExts
123+ where
124+ autoExts = allExts L.\\ manualExts
125+ allExts = [minBound .. maxBound]
74
126
75-- | Extensions that are not enabled automatically and should be activated
127-- | Extensions that are not enabled automatically and should be activated
76-- by user.
128-- by user.
@@ -91,55 +143,13 @@ manualExts =
91 MonadComprehensions,
143 MonadComprehensions,
92 UnboxedSums,
144 UnboxedSums,
93 UnicodeSyntax, -- gives special meanings to operators like (→)
145 UnicodeSyntax, -- gives special meanings to operators like (→)
94− TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
146+ TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this
95 -- apparently interferes with QuasiQuotes in
147 -- apparently interferes with QuasiQuotes in
96 -- weird ways
148 -- weird ways
149+ ImportQualifiedPost -- affects how Ormolu renders imports, so the
150+ -- decision of enabling this style is left to the user
97 ]
151 ]
98
152
99−----------------------------------------------------------------------------
100−-- Helpers (taken from ghc-exactprint)
101−
102−-- | Requires GhcMonad constraint because there is no pure variant of
103−-- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does
104−-- not (try to) read the file at filepath, but solely depends on the module
105−-- source in the input string.
106−--
107−-- Passes "-hide-all-packages" to the GHC API to prevent parsing of package
108−-- environment files. However this only works if there is no invocation of
109−-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets
110−-- #15513, #15541.
111−initDynFlagsPure ::
112− GHC.GhcMonad m =>
113− -- | Module path
114− FilePath ->
115− -- | Module contents
116− String ->
117− -- | Dynamic flags for that module
118− m GHC.DynFlags
119−initDynFlagsPure fp input = do
120− -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as
121− -- long as 'parseDynamicFilePragma' is impure there seems to be no reason
122− -- to use it.
123− dflags0 <- setDefaultExts <$> GHC.getSessionDynFlags
124− let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp
125− (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens
126− -- Turn this on last to avoid T10942
127− let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
128− -- Prevent parsing of .ghc.environment.* "package environment files"
129− (dflags3, _, _) <-
130− GHC.parseDynamicFlagsCmdLine
131− dflags2
132− [GHC.noLoc "-hide-all-packages"]
133− _ <- GHC.setSessionDynFlags dflags3
134− return dflags3
135−
136−-- | Default runner of 'GHC.Ghc' action in 'IO'.
137−ghcWrapper :: GHC.Ghc a -> IO a
138−ghcWrapper act =
139− let GHC.FlushOut flushOut = GHC.defaultFlushOut
140− in GHC.runGhc (Just libdir) act
141− `finally` flushOut
142−
143-- | Run a 'GHC.P' computation.
153-- | Run a 'GHC.P' computation.
144runParser ::
154runParser ::
145 -- | Computation to run
155 -- | Computation to run
@@ -158,44 +168,52 @@ runParser parser flags filename input = GHC.unP parser parseState
158 buffer = GHC.stringToStringBuffer input
168 buffer = GHC.stringToStringBuffer input
159 parseState = GHC.mkPState flags buffer location
169 parseState = GHC.mkPState flags buffer location
160
170
161−-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
171+-- | Wrap GHC's 'Severity' to add 'Ord' instance.
162−-- comments.
172+newtype SeverityOrd = SeverityOrd Severity
163−stripLinePragmas :: FilePath -> String -> (String, [Located String])
164−stripLinePragmas path = unlines' . unzip . findLines path . lines
165− where
166− unlines' (a, b) = (unlines a, catMaybes b)
167
173
168−findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
174+instance Eq SeverityOrd where
169−findLines path = zipWith (checkLine path) [1 ..]
175+ s1 == s2 = compare s1 s2 == EQ
170
176
171−checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
177+instance Ord SeverityOrd where
172−checkLine path line s
178+ compare (SeverityOrd s1) (SeverityOrd s2) =
173− | "{-# LINE" `isPrefixOf` s =
179+ compare (f s1) (f s2)
174− let (pragma, res) = getPragma s
180+ where
175− size = length pragma
181+ f :: Severity -> Int
176− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
182+ f SevOutput = 1
177− in (res, Just $ L ss pragma)
183+ f SevFatal = 2
178− | "#!" `isPrefixOf` s =
184+ f SevInteractive = 3
179− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
185+ f SevDump = 4
180− in ("", Just $ L ss s)
186+ f SevInfo = 5
181− | otherwise = (s, Nothing)
187+ f SevWarning = 6
182− where
188+ f SevError = 7
183− mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
184
189
185−getPragma :: String -> (String, String)
190+----------------------------------------------------------------------------
186−getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
191+-- Helpers taken from HLint
187−getPragma s@(x : xs)
188− | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
189− | otherwise =
190− let (prag, remline) = getPragma xs
191− in (x : prag, ' ' : remline)
192
192
193−-- | Enable all language extensions that we think should be enabled by
193+parsePragmasIntoDynFlags ::
194−-- default for ease of use.
194+ -- | Pre-set 'DynFlags'
195−setDefaultExts :: DynFlags -> DynFlags
195+ DynFlags ->
196−setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
196+ -- | Extra options (provided by user)
197+ [Located String] ->
198+ -- | File name (only for source location annotations)
199+ FilePath ->
200+ -- | Input for parser
201+ String ->
202+ IO (Either String ([GHC.Warn], DynFlags))
203+parsePragmasIntoDynFlags flags extraOpts filepath str =
204+ catchErrors $ do
205+ let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath
206+ (flags', leftovers, warnings) <-
207+ parseDynamicFilePragma flags (opts <> extraOpts)
208+ case NE.nonEmpty leftovers of
209+ Nothing -> return ()
210+ Just unrecognizedOpts ->
211+ throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts))
212+ let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream
213+ return $ Right (warnings, flags'')
197 where
214 where
198− autoExts = allExts \\ manualExts
215+ catchErrors act =
199− allExts = [minBound .. maxBound]
216+ GHC.handleGhcException
200−
217+ reportErr
201−deriving instance Bounded Extension
218+ (GHC.handleSourceError reportErr act)
219+ reportErr e = return $ Left (show e)
src/Ormolu/Parser/CommentStream.hs+154−65
@@ -1,78 +1,77 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
5−{-# LANGUAGE TupleSections #-}
6
4
7-- | Functions for working with comment stream.
5-- | Functions for working with comment stream.
8module Ormolu.Parser.CommentStream
6module Ormolu.Parser.CommentStream
9− ( CommentStream (..),
7+ ( -- * Comment stream
10− Comment (..),
8+ CommentStream (..),
11 mkCommentStream,
9 mkCommentStream,
12− isPrevHaddock,
13− isMultilineComment,
14 showCommentStream,
10 showCommentStream,
11+
12+ -- * Comment
13+ Comment (..),
14+ unComment,
15+ hasAtomsBefore,
16+ isMultilineComment,
15 )
17 )
16where
18where
17
19
18import Data.Char (isSpace)
20import Data.Char (isSpace)
19import Data.Data (Data)
21import Data.Data (Data)
20−import Data.Either (partitionEithers)
22+import qualified Data.List as L
21−import Data.List (dropWhileEnd, isPrefixOf, sortOn)
22import Data.List.NonEmpty (NonEmpty (..))
23import Data.List.NonEmpty (NonEmpty (..))
23import qualified Data.List.NonEmpty as NE
24import qualified Data.List.NonEmpty as NE
24import Data.Maybe (mapMaybe)
25import Data.Maybe (mapMaybe)
25import qualified GHC
26import qualified GHC
26import qualified Lexer as GHC
27import qualified Lexer as GHC
27import Ormolu.Parser.Pragma
28import Ormolu.Parser.Pragma
29+import Ormolu.Parser.Shebang
30+import Ormolu.Processing.Common
28−import Ormolu.Utils (showOutputable)
31+import Ormolu.Utils (onTheSameLine, showOutputable)
29import SrcLoc
32import SrcLoc
30
33
34+----------------------------------------------------------------------------
35+-- Comment stream
36+
31-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
37-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
32-- beginning of corresponding spans.
38-- beginning of corresponding spans.
33newtype CommentStream = CommentStream [RealLocated Comment]
39newtype CommentStream = CommentStream [RealLocated Comment]
34 deriving (Eq, Data, Semigroup, Monoid)
40 deriving (Eq, Data, Semigroup, Monoid)
35
41
36−-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
37−-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
38−newtype Comment = Comment (NonEmpty String)
39− deriving (Eq, Show, Data)
40−
41−-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
42+-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are
42−-- extensions here, which is not sorted in any way. The pragma comment are
43−-- removed from the 'CommentStream'.
43+-- removed from the 'CommentStream'. Shebangs are only extracted from the
44+-- comments that come from the first argument.
44mkCommentStream ::
45mkCommentStream ::
46+ -- | Original input
47+ String ->
45 -- | Extra comments to include
48 -- | Extra comments to include
46 [Located String] ->
49 [Located String] ->
47 -- | Parser state to use for comment extraction
50 -- | Parser state to use for comment extraction
48 GHC.PState ->
51 GHC.PState ->
49− -- | Comment stream and a set of extracted pragmas
52+ -- | Stack header, shebangs, pragmas, and comment stream
50− (CommentStream, [Pragma])
53+ ( Maybe (RealLocated Comment),
54+ [Shebang],
55+ [([RealLocated Comment], Pragma)],
56+ CommentStream
57+ )
51−mkCommentStream extraComments pstate =
58+mkCommentStream input extraComments pstate =
52− ( CommentStream $
59+ ( mstackHeader,
53− -- NOTE It's easier to normalize pragmas right when we construct comment
60+ shebangs,
54− -- streams. Because this way we need to do it only once and when we
61+ pragmas,
55− -- perform checking later they'll automatically match.
62+ CommentStream comments
56− mkComment <$> sortOn (realSrcSpanStart . getLoc) comments,
57− pragmas
58 )
63 )
59 where
64 where
60− (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
65+ (comments, pragmas) = extractPragmas input rawComments1
61− rawComments =
66+ (rawComments1, mstackHeader) = extractStackHeader rawComments0
67+ rawComments0 =
62− mapMaybe toRealSpan $
68+ L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $
63− extraComments
69+ otherExtraComments
64 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
70 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
71+ ++ concatMap
65− ++ concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
72+ (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
66 (GHC.annotations_comments pstate)
73 (GHC.annotations_comments pstate)
67−
74+ (shebangs, otherExtraComments) = extractShebangs extraComments
68−-- | Test whether a 'Comment' looks like a Haddock following a definition,
69−-- i.e. something starting with @-- ^@.
70−isPrevHaddock :: Comment -> Bool
71−isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
72−
73−-- | Is this comment multiline-style?
74−isMultilineComment :: Comment -> Bool
75−isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
76
75
77-- | Pretty-print a 'CommentStream'.
76-- | Pretty-print a 'CommentStream'.
78showCommentStream :: CommentStream -> String
77showCommentStream :: CommentStream -> String
@@ -83,28 +82,117 @@ showCommentStream (CommentStream xs) =
83 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
82 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
84
83
85----------------------------------------------------------------------------
84----------------------------------------------------------------------------
86−-- Helpers
85+-- Comment
86+
87+-- | A wrapper for a single comment. The 'Bool' indicates whether there were
88+-- atoms before beginning of the comment in the original input. The
89+-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or
90+-- just single item\/line otherwise.
91+data Comment = Comment Bool (NonEmpty String)
92+ deriving (Eq, Show, Data)
87
93
88-- | Normalize comment string. Sometimes one multi-line comment is turned
94-- | Normalize comment string. Sometimes one multi-line comment is turned
89-- into several lines for subsequent outputting with correct indentation for
95-- into several lines for subsequent outputting with correct indentation for
90-- each line.
96-- each line.
91−mkComment :: RealLocated String -> RealLocated Comment
97+mkComment ::
92−mkComment (L l s) =
98+ -- | Lines of original input with their indices
93− L l . Comment . fmap dropTrailing $
99+ [(Int, String)] ->
94− if "{-" `isPrefixOf` s
100+ -- | Raw comment string
95− then case NE.nonEmpty (lines s) of
101+ RealLocated String ->
96− Nothing -> s :| []
102+ -- | Remaining lines of original input and the constructed 'Comment'
97− Just (x :| xs) ->
103+ ([(Int, String)], RealLocated Comment)
98− let getIndent y =
104+mkComment ls (L l s) = (ls', comment)
99− if all isSpace y
100− then startIndent
101− else length (takeWhile isSpace y)
102− n = minimum (startIndent : fmap getIndent xs)
103− in x :| (drop n <$> xs)
104− else s :| []
105 where
105 where
106+ comment =
107+ L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $
108+ if "{-" `L.isPrefixOf` s
109+ then case NE.nonEmpty (lines s) of
110+ Nothing -> s :| []
111+ Just (x :| xs) ->
112+ let getIndent y =
113+ if all isSpace y || y == endDisabling
114+ then startIndent
115+ else length (takeWhile isSpace y)
116+ n = minimum (startIndent : fmap getIndent xs)
117+ removeIndent y =
118+ if y == endDisabling
119+ then y
120+ else drop n y
121+ in x :| (removeIndent <$> xs)
122+ else s :| []
123+ (atomsBefore, ls') =
124+ case dropWhile ((< commentLine) . fst) ls of
125+ [] -> (False, [])
126+ ((_, i) : ls'') ->
127+ case take 2 (dropWhile isSpace i) of
128+ "--" -> (False, ls'')
129+ "{-" -> (False, ls'')
130+ _ -> (True, ls'')
106− dropTrailing = dropWhileEnd isSpace
131+ dropTrailing = L.dropWhileEnd isSpace
107 startIndent = srcSpanStartCol l - 1
132 startIndent = srcSpanStartCol l - 1
133+ commentLine = srcSpanStartLine l
134+
135+-- | Get a collection of lines from a 'Comment'.
136+unComment :: Comment -> NonEmpty String
137+unComment (Comment _ xs) = xs
138+
139+-- | Check whether the 'Comment' had some non-whitespace atoms in front of
140+-- it in the original input.
141+hasAtomsBefore :: Comment -> Bool
142+hasAtomsBefore (Comment atomsBefore _) = atomsBefore
143+
144+-- | Is this comment multiline-style?
145+isMultilineComment :: Comment -> Bool
146+isMultilineComment (Comment _ (x :| _)) = "{-" `L.isPrefixOf` x
147+
148+----------------------------------------------------------------------------
149+-- Helpers
150+
151+-- | Detect and extract stack header if it is present.
152+extractStackHeader ::
153+ -- | Comment stream to analyze
154+ [RealLocated String] ->
155+ ([RealLocated String], Maybe (RealLocated Comment))
156+extractStackHeader = \case
157+ [] -> ([], Nothing)
158+ (x : xs) ->
159+ let comment = snd (mkComment [] x)
160+ in if isStackHeader (unRealSrcSpan comment)
161+ then (xs, Just comment)
162+ else (x : xs, Nothing)
163+ where
164+ isStackHeader (Comment _ (x :| _)) =
165+ "stack" `L.isPrefixOf` dropWhile isSpace (drop 2 x)
166+
167+-- | Extract pragmas and their associated comments.
168+extractPragmas ::
169+ -- | Input
170+ String ->
171+ -- | Comment stream to analyze
172+ [RealLocated String] ->
173+ ([RealLocated Comment], [([RealLocated Comment], Pragma)])
174+extractPragmas input = go initialLs id id
175+ where
176+ initialLs = zip [1 ..] (lines input)
177+ go ls csSoFar pragmasSoFar = \case
178+ [] -> (csSoFar [], pragmasSoFar [])
179+ (x : xs) ->
180+ case parsePragma (unRealSrcSpan x) of
181+ Nothing ->
182+ let (ls', x') = mkComment ls x
183+ in go ls' (csSoFar . (x' :)) pragmasSoFar xs
184+ Just pragma ->
185+ let combined ys = (csSoFar ys, pragma)
186+ go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest
187+ in case xs of
188+ [] -> go' ls [] xs
189+ (y : ys) ->
190+ let (ls', y') = mkComment ls y
191+ in if onTheSameLine
192+ (RealSrcSpan (getRealSrcSpan x))
193+ (RealSrcSpan (getRealSrcSpan y))
194+ then go' ls' [y'] ys
195+ else go' ls [] xs
108
196
109-- | Get a 'String' from 'GHC.AnnotationComment'.
197-- | Get a 'String' from 'GHC.AnnotationComment'.
110unAnnotationComment :: GHC.AnnotationComment -> Maybe String
198unAnnotationComment :: GHC.AnnotationComment -> Maybe String
@@ -126,12 +214,13 @@ toRealSpan :: Located a -> Maybe (RealLocated a)
126toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
214toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
127toRealSpan _ = Nothing
215toRealSpan _ = Nothing
128
216
129−-- | If a given comment is a pragma, return it in parsed form in 'Right'.
217+-- | Remove consecutive blank lines.
130−-- Otherwise return the original comment unchanged.
218+removeConseqBlanks :: NonEmpty String -> NonEmpty String
131−partitionComments ::
219+removeConseqBlanks (x :| xs) = x :| go (null x) id xs
132− RealLocated String ->
220+ where
133− Either (RealLocated String) Pragma
221+ go seenBlank acc = \case
134−partitionComments input =
222+ [] -> acc []
135− case parsePragma (unLoc input) of
223+ (y : ys) ->
136− Nothing -> Left input
224+ if seenBlank && null y
137− Just pragma -> Right pragma
225+ then go True acc ys
226+ else go (null y) (acc . (y :)) ys
src/Ormolu/Parser/Pragma.hs+14−11
@@ -10,7 +10,7 @@ where
10
10
11import Control.Monad
11import Control.Monad
12import Data.Char (isSpace, toLower)
12import Data.Char (isSpace, toLower)
13−import Data.List
13+import qualified Data.List as L
14import qualified EnumSet as ES
14import qualified EnumSet as ES
15import FastString (mkFastString, unpackFS)
15import FastString (mkFastString, unpackFS)
16import qualified Lexer as L
16import qualified Lexer as L
@@ -35,8 +35,8 @@ parsePragma ::
35 String ->
35 String ->
36 Maybe Pragma
36 Maybe Pragma
37parsePragma input = do
37parsePragma input = do
38− inputNoPrefix <- stripPrefix "{-#" input
38+ inputNoPrefix <- L.stripPrefix "{-#" input
39− guard ("#-}" `isSuffixOf` input)
39+ guard ("#-}" `L.isSuffixOf` input)
40 let contents = take (length inputNoPrefix - 3) inputNoPrefix
40 let contents = take (length inputNoPrefix - 3) inputNoPrefix
41 (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents
41 (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents
42 case toLower <$> pragmaName of
42 case toLower <$> pragmaName of
@@ -46,7 +46,7 @@ parsePragma input = do
46 _ -> Nothing
46 _ -> Nothing
47 where
47 where
48 trimSpaces :: String -> String
48 trimSpaces :: String -> String
49− trimSpaces = dropWhileEnd isSpace . dropWhile isSpace
49+ trimSpaces = L.dropWhileEnd isSpace . dropWhile isSpace
50
50
51-- | Assuming the input consists of a series of tokens from a language
51-- | Assuming the input consists of a series of tokens from a language
52-- pragma, return the set of enabled extensions.
52-- pragma, return the set of enabled extensions.
@@ -54,7 +54,7 @@ parseExtensions :: String -> Maybe [String]
54parseExtensions str = tokenize str >>= go
54parseExtensions str = tokenize str >>= go
55 where
55 where
56 go = \case
56 go = \case
57− (L.ITconid ext : []) -> return [unpackFS ext]
57+ [L.ITconid ext] -> return [unpackFS ext]
58 (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs
58 (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs
59 _ -> Nothing
59 _ -> Nothing
60
60
@@ -68,12 +68,15 @@ tokenize input =
68 location = mkRealSrcLoc (mkFastString "") 1 1
68 location = mkRealSrcLoc (mkFastString "") 1 1
69 buffer = stringToStringBuffer input
69 buffer = stringToStringBuffer input
70 parseState = L.mkPStatePure parserFlags buffer location
70 parseState = L.mkPStatePure parserFlags buffer location
71− parserFlags = L.ParserFlags
71+ parserFlags =
72+ L.mkParserFlags'
72− { L.pWarningFlags = ES.empty,
73+ ES.empty
73− L.pExtensionFlags = ES.empty,
74+ ES.empty
74− L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),
75+ (newSimpleUnitId (ComponentId (mkFastString "")))
75− L.pExtsBitmap = 0xffffffffffffffff
76+ True
76− }
77+ True
78+ True
79+ True
77
80
78-- | Haskell lexer.
81-- | Haskell lexer.
79pLexer :: L.P [L.Token]
82pLexer :: L.P [L.Token]
src/Ormolu/Parser/Result.hs+26−11
@@ -7,23 +7,38 @@ module Ormolu.Parser.Result
7 )
7 )
8where
8where
9
9
10+import Data.Text (Text)
10import GHC
11import GHC
11import Ormolu.Parser.Anns
12import Ormolu.Parser.Anns
12import Ormolu.Parser.CommentStream
13import Ormolu.Parser.CommentStream
13import Ormolu.Parser.Pragma (Pragma)
14import Ormolu.Parser.Pragma (Pragma)
15+import Ormolu.Parser.Shebang (Shebang)
14
16
15-- | A collection of data that represents a parsed module in Ormolu.
17-- | A collection of data that represents a parsed module in Ormolu.
16−data ParseResult
18+data ParseResult = ParseResult
17− = ParseResult
18− { -- | 'ParsedSource' from GHC
19+ { -- | 'ParsedSource' from GHC
19− prParsedSource :: ParsedSource,
20+ prParsedSource :: HsModule GhcPs,
20− -- | Ormolu-specfic representation of annotations
21+ -- | Ormolu-specfic representation of annotations
21− prAnns :: Anns,
22+ prAnns :: Anns,
23+ -- | Stack header
24+ prStackHeader :: Maybe (RealLocated Comment),
25+ -- | Shebangs found in the input
26+ prShebangs :: [Shebang],
27+ -- | Pragmas and the associated comments
28+ prPragmas :: [([RealLocated Comment], Pragma)],
22− -- | Comment stream
29+ -- | Comment stream
23− prCommentStream :: CommentStream,
30+ prCommentStream :: CommentStream,
24− -- | Extensions enabled in that module
31+ -- | Whether or not record dot syntax is enabled
25− prExtensions :: [Pragma]
32+ 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
26− }
41+ }
27
42
28-- | Pretty-print a 'ParseResult'.
43-- | Pretty-print a 'ParseResult'.
29prettyPrintParseResult :: ParseResult -> String
44prettyPrintParseResult :: ParseResult -> String
src/Ormolu/Parser/Shebang.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+-- | A module for dealing with shebangs.
4+module Ormolu.Parser.Shebang
5+ ( Shebang (..),
6+ extractShebangs,
7+ isShebang,
8+ )
9+where
10+
11+import Data.Data (Data)
12+import qualified Data.List as L
13+import SrcLoc
14+
15+-- | A wrapper for a shebang.
16+newtype Shebang = Shebang (Located String)
17+ deriving (Eq, Data)
18+
19+-- | Extract shebangs from the beginning of a comment stream.
20+extractShebangs :: [Located String] -> ([Shebang], [Located String])
21+extractShebangs comments = (Shebang <$> shebangs, rest)
22+ where
23+ (shebangs, rest) = span (isShebang . unLoc) comments
24+
25+-- | Return 'True' if given 'String' is a shebang.
26+isShebang :: String -> Bool
27+isShebang str = "#!" `L.isPrefixOf` str
src/Ormolu/Printer.hs+17−6
@@ -1,5 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
4
2
5-- | Pretty-printer for Haskell AST.
3-- | Pretty-printer for Haskell AST.
@@ -13,6 +11,7 @@ import Ormolu.Parser.Result
13import Ormolu.Printer.Combinators
11import Ormolu.Printer.Combinators
14import Ormolu.Printer.Meat.Module
12import Ormolu.Printer.Meat.Module
15import Ormolu.Printer.SpanStream
13import Ormolu.Printer.SpanStream
14+import Ormolu.Processing.Postprocess (postprocess)
16
15
17-- | Render a module.
16-- | Render a module.
18printModule ::
17printModule ::
@@ -21,7 +20,19 @@ printModule ::
21 -- | Resulting rendition
20 -- | Resulting rendition
22 Text
21 Text
23printModule ParseResult {..} =
22printModule ParseResult {..} =
23+ prLiteralPrefix <> region <> prLiteralSuffix
24+ where
25+ region =
26+ postprocess prIndent $
27+ runR
28+ ( p_hsModule
29+ prStackHeader
30+ prShebangs
31+ prPragmas
32+ prImportQualifiedPost
24− runR (p_hsModule prExtensions prParsedSource)
33+ prParsedSource
34+ )
25− (mkSpanStream prParsedSource)
35+ (mkSpanStream prParsedSource)
26− prCommentStream
36+ prCommentStream
27− prAnns
37+ prAnns
38+ prUseRecordDot
src/Ormolu/Printer/Combinators.hs+41−30
@@ -1,6 +1,7 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
1{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4
5
5-- | Printing combinators. The definitions here are presented in such an
6-- | Printing combinators. The definitions here are presented in such an
6-- order so you can just go through the Haddocks and by the end of the file
7-- order so you can just go through the Haddocks and by the end of the file
@@ -20,6 +21,7 @@ module Ormolu.Printer.Combinators
20 space,
21 space,
21 newline,
22 newline,
22 inci,
23 inci,
24+ inciIf,
23 located,
25 located,
24 located',
26 located',
25 switchLayout,
27 switchLayout,
@@ -50,57 +52,57 @@ module Ormolu.Printer.Combinators
50
52
51 -- ** Literals
53 -- ** Literals
52 comma,
54 comma,
55+ commaDel,
56+ equals,
53
57
54− -- ** Comments
58+ -- ** Stateful markers
59+ SpanMark (..),
60+ spanMarkSpan,
55 HaddockStyle (..),
61 HaddockStyle (..),
56− setLastCommentSpan,
62+ setSpanMark,
57− getLastCommentSpan,
63+ getSpanMark,
58 )
64 )
59where
65where
60
66
61import Control.Monad
67import Control.Monad
62−import Data.Data (Data)
63import Data.List (intersperse)
68import Data.List (intersperse)
64import Data.Text (Text)
69import Data.Text (Text)
65import Ormolu.Printer.Comments
70import Ormolu.Printer.Comments
66import Ormolu.Printer.Internal
71import Ormolu.Printer.Internal
67−import Ormolu.Utils (isModule)
68import SrcLoc
72import SrcLoc
69
73
70----------------------------------------------------------------------------
74----------------------------------------------------------------------------
71-- Basic
75-- Basic
72
76
77+-- | Indent the inner expression if the first argument is 'True'.
78+inciIf ::
79+ -- | Whether to indent
80+ Bool ->
81+ -- | The expression to indent
82+ R () ->
83+ R ()
84+inciIf b m = if b then inci m else m
85+
73-- | Enter a 'Located' entity. This combinator handles outputting comments
86-- | Enter a 'Located' entity. This combinator handles outputting comments
74-- and sets layout (single-line vs multi-line) for the inner computation.
87-- and sets layout (single-line vs multi-line) for the inner computation.
75-- Roughly, the rule for using 'located' is that every time there is a
88-- Roughly, the rule for using 'located' is that every time there is a
76-- 'Located' wrapper, it should be “discharged” with a corresponding
89-- 'Located' wrapper, it should be “discharged” with a corresponding
77-- 'located' invocation.
90-- 'located' invocation.
78located ::
91located ::
79− Data a =>
80 -- | Thing to enter
92 -- | Thing to enter
81 Located a ->
93 Located a ->
82 -- | How to render inner value
94 -- | How to render inner value
83 (a -> R ()) ->
95 (a -> R ()) ->
84 R ()
96 R ()
85−located loc f = do
97+located (L (UnhelpfulSpan _) a) f = f a
86− let withRealLocated (L l a) g =
98+located (L (RealSrcSpan l) a) f = do
87− case l of
88− UnhelpfulSpan _ -> return ()
89− RealSrcSpan l' -> g (L l' a)
90− withRealLocated loc spitPrecedingComments
99+ spitPrecedingComments l
91− let setEnclosingSpan =
92− case getLoc loc of
93− UnhelpfulSpan _ -> id
94− RealSrcSpan orf ->
95− if isModule (unLoc loc)
96− then id
97− else withEnclosingSpan orf
100+ withEnclosingSpan l $
98− setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))
101+ switchLayout [RealSrcSpan l] (f a)
99− withRealLocated loc spitFollowingComments
102+ spitFollowingComments l
100
103
101-- | A version of 'located' with arguments flipped.
104-- | A version of 'located' with arguments flipped.
102located' ::
105located' ::
103− Data a =>
104 -- | How to render inner value
106 -- | How to render inner value
105 (a -> R ()) ->
107 (a -> R ()) ->
106 -- | Thing to enter
108 -- | Thing to enter
@@ -183,10 +185,12 @@ sepSemi f xs = vlayout singleLine multiLine
183 xs' ->
185 xs' ->
184 if ub
186 if ub
185 then do
187 then do
186− txt "{ "
188+ txt "{"
189+ space
187− sep (txt "; ") (dontUseBraces . f) xs'
190+ sep (txt ";" >> space) (dontUseBraces . f) xs'
191+ space
188− txt " }"
192+ txt "}"
189− else sep (txt "; ") f xs'
193+ else sep (txt ";" >> space) f xs'
190 multiLine =
194 multiLine =
191 sep newline (dontUseBraces . f) xs
195 sep newline (dontUseBraces . f) xs
192
196
@@ -199,6 +203,7 @@ data BracketStyle
199 N
203 N
200 | -- | Shifted one level
204 | -- | Shifted one level
201 S
205 S
206+ deriving (Eq, Show)
202
207
203-- | Surround given entity by backticks.
208-- | Surround given entity by backticks.
204backticks :: R () -> R ()
209backticks :: R () -> R ()
@@ -275,9 +280,7 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
275 then newline >> inci m
280 then newline >> inci m
276 else space >> sitcc m
281 else space >> sitcc m
277 newline
282 newline
278− case style of
279− N -> txt close
280− S -> inci (txt close)
283+ inciIf (style == S) (txt close)
281
284
282----------------------------------------------------------------------------
285----------------------------------------------------------------------------
283-- Literals
286-- Literals
@@ -285,3 +288,11 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
285-- | Print @,@.
288-- | Print @,@.
286comma :: R ()
289comma :: R ()
287comma = txt ","
290comma = txt ","
291+
292+-- | Delimiting combination with 'comma'. To be used with 'sep'.
293+commaDel :: R ()
294+commaDel = comma >> breakpoint
295+
296+-- | Print @=@. Do not use @'txt' "="@.
297+equals :: R ()
298+equals = interferingTxt "="
src/Ormolu/Printer/Comments.hs+69−78
@@ -7,17 +7,17 @@ module Ormolu.Printer.Comments
7 ( spitPrecedingComments,
7 ( spitPrecedingComments,
8 spitFollowingComments,
8 spitFollowingComments,
9 spitRemainingComments,
9 spitRemainingComments,
10+ spitCommentNow,
11+ spitCommentPending,
10 )
12 )
11where
13where
12
14
13import Control.Monad
15import Control.Monad
14−import Data.Coerce (coerce)
15−import Data.Data (Data)
16import qualified Data.List.NonEmpty as NE
16import qualified Data.List.NonEmpty as NE
17+import Data.Maybe (listToMaybe)
17import qualified Data.Text as T
18import qualified Data.Text as T
18import Ormolu.Parser.CommentStream
19import Ormolu.Parser.CommentStream
19import Ormolu.Printer.Internal
20import Ormolu.Printer.Internal
20−import Ormolu.Utils (isModule)
21import SrcLoc
21import SrcLoc
22
22
23----------------------------------------------------------------------------
23----------------------------------------------------------------------------
@@ -25,105 +25,91 @@ import SrcLoc
25
25
26-- | Output all preceding comments for an element at given location.
26-- | Output all preceding comments for an element at given location.
27spitPrecedingComments ::
27spitPrecedingComments ::
28− Data a =>
29− -- | AST element to attach comments to
28+ -- | Span of the element to attach comments to
30− RealLocated a ->
29+ RealSrcSpan ->
31 R ()
30 R ()
32spitPrecedingComments ref = do
31spitPrecedingComments ref = do
33− r <- getLastCommentSpan
34− case r of
35− Just (Just Pipe, _) ->
36− -- We should not insert comments between pipe Haddock and the thing
37− -- it's attached to.
38− return ()
39− _ -> do
40− gotSome <- handleCommentSeries (spitPrecedingComment ref)
32+ gotSome <- handleCommentSeries (spitPrecedingComment ref)
41− when gotSome $ do
33+ when gotSome $ do
34+ lastMark <- getSpanMark
42− -- Insert a blank line between the preceding comments and the thing
35+ -- Insert a blank line between the preceding comments and the thing
43− -- after them if there was a blank line in the input.
36+ -- after them if there was a blank line in the input.
44− lastSpn <- fmap snd <$> getLastCommentSpan
45− when (needsNewlineBefore (getLoc ref) lastSpn) newline
37+ when (needsNewlineBefore ref lastMark) newline
46
38
47-- | Output all comments following an element at given location.
39-- | Output all comments following an element at given location.
48spitFollowingComments ::
40spitFollowingComments ::
49− Data a =>
50− -- | AST element of attach comments to
41+ -- | Span of the element to attach comments to
51− RealLocated a ->
42+ RealSrcSpan ->
52 R ()
43 R ()
53spitFollowingComments ref = do
44spitFollowingComments ref = do
54− trimSpanStream (getLoc ref)
45+ trimSpanStream ref
55 void $ handleCommentSeries (spitFollowingComment ref)
46 void $ handleCommentSeries (spitFollowingComment ref)
56
47
57-- | Output all remaining comments in the comment stream.
48-- | Output all remaining comments in the comment stream.
58spitRemainingComments :: R ()
49spitRemainingComments :: R ()
50+spitRemainingComments = do
51+ -- Make sure we have a blank a line between the last definition and the
52+ -- trailing comments.
53+ newline
59−spitRemainingComments = void $ handleCommentSeries spitRemainingComment
54+ void $ handleCommentSeries spitRemainingComment
60
55
61----------------------------------------------------------------------------
56----------------------------------------------------------------------------
62-- Single-comment functions
57-- Single-comment functions
63
58
64-- | Output a single preceding comment for an element at given location.
59-- | Output a single preceding comment for an element at given location.
65spitPrecedingComment ::
60spitPrecedingComment ::
66− Data a =>
67− -- | AST element to attach comments to
61+ -- | Span of the element to attach comments to
68− RealLocated a ->
69− -- | Location of last comment in the series
70− Maybe RealSrcSpan ->
62+ RealSrcSpan ->
71 -- | Are we done?
63 -- | Are we done?
72 R Bool
64 R Bool
73−spitPrecedingComment (L ref a) mlastSpn = do
65+spitPrecedingComment ref = do
66+ mlastMark <- getSpanMark
74 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
67 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
75 withPoppedComment p $ \l comment -> do
68 withPoppedComment p $ \l comment -> do
76− dirtyLine <-
69+ lineSpans <- thisLineSpans
77− case mlastSpn of
70+ let thisCommentLine = srcLocLine (realSrcSpanStart l)
78− -- NOTE When the current line is dirty it means that something that
71+ needsNewline =
79− -- can have comments attached to it is already on the line. To avoid
72+ case listToMaybe lineSpans of
80− -- problems with idempotence we cannot output the first comment
73+ Nothing -> False
81− -- immediately because it'll be attached to the previous element (on
74+ Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine
82− -- the same line) on the next run, so we play safe here and output
83− -- an extra 'newline' in this case.
84− Nothing -> isLineDirty -- only for very first preceding comment
85− Just _ -> return False
86− when (dirtyLine || needsNewlineBefore l mlastSpn) newline
75+ when (needsNewline || needsNewlineBefore l mlastMark) newline
87 spitCommentNow l comment
76 spitCommentNow l comment
88− if theSameLinePre l ref && not (isModule a)
77+ if theSameLinePre l ref
89 then space
78 then space
90 else newline
79 else newline
91
80
92-- | Output a comment that follows element at given location immediately on
81-- | Output a comment that follows element at given location immediately on
93-- the same line, if there is any.
82-- the same line, if there is any.
94spitFollowingComment ::
83spitFollowingComment ::
95− Data a =>
96 -- | AST element to attach comments to
84 -- | AST element to attach comments to
97− RealLocated a ->
98− -- | Location of last comment in the series
99− Maybe RealSrcSpan ->
85+ RealSrcSpan ->
100 -- | Are we done?
86 -- | Are we done?
101 R Bool
87 R Bool
102−spitFollowingComment (L ref a) mlastSpn = do
88+spitFollowingComment ref = do
89+ mlastMark <- getSpanMark
103 mnSpn <- nextEltSpan
90 mnSpn <- nextEltSpan
104 -- Get first enclosing span that is not equal to reference span, i.e. it's
91 -- Get first enclosing span that is not equal to reference span, i.e. it's
105 -- truly something enclosing the AST element.
92 -- truly something enclosing the AST element.
106 meSpn <- getEnclosingSpan (/= ref)
93 meSpn <- getEnclosingSpan (/= ref)
107− withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
94+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->
108− if theSameLinePost l ref && not (isModule a)
95+ if theSameLinePost l ref
109 then
96 then
110 if isMultilineComment comment
97 if isMultilineComment comment
111 then space >> spitCommentNow l comment
98 then space >> spitCommentNow l comment
112 else spitCommentPending OnTheSameLine l comment
99 else spitCommentPending OnTheSameLine l comment
113 else do
100 else do
114− when (needsNewlineBefore l mlastSpn) $
101+ when (needsNewlineBefore l mlastMark) $
115 registerPendingCommentLine OnNextLine ""
102 registerPendingCommentLine OnNextLine ""
116 spitCommentPending OnNextLine l comment
103 spitCommentPending OnNextLine l comment
117
104
118-- | Output a single remaining comment from the comment stream.
105-- | Output a single remaining comment from the comment stream.
119spitRemainingComment ::
106spitRemainingComment ::
120− -- | Location of last comment in the series
121− Maybe RealSrcSpan ->
122 -- | Are we done?
107 -- | Are we done?
123 R Bool
108 R Bool
124−spitRemainingComment mlastSpn =
109+spitRemainingComment = do
110+ mlastMark <- getSpanMark
125 withPoppedComment (const True) $ \l comment -> do
111 withPoppedComment (const True) $ \l comment -> do
126− when (needsNewlineBefore l mlastSpn) newline
112+ when (needsNewlineBefore l mlastMark) newline
127 spitCommentNow l comment
113 spitCommentNow l comment
128 newline
114 newline
129
115
@@ -134,13 +120,13 @@ spitRemainingComment mlastSpn =
134handleCommentSeries ::
120handleCommentSeries ::
135 -- | Given location of previous comment, output the next comment
121 -- | Given location of previous comment, output the next comment
136 -- returning 'True' if we're done
122 -- returning 'True' if we're done
137− (Maybe RealSrcSpan -> R Bool) ->
123+ R Bool ->
138 -- | Whether we printed any comments
124 -- | Whether we printed any comments
139 R Bool
125 R Bool
140handleCommentSeries f = go False
126handleCommentSeries f = go False
141 where
127 where
142 go gotSome = do
128 go gotSome = do
143− done <- getLastCommentSpan >>= f . fmap snd
129+ done <- f
144 if done
130 if done
145 then return gotSome
131 then return gotSome
146 else go True
132 else go True
@@ -166,13 +152,14 @@ needsNewlineBefore ::
166 -- | Current comment span
152 -- | Current comment span
167 RealSrcSpan ->
153 RealSrcSpan ->
168 -- | Last printed comment span
154 -- | Last printed comment span
169− Maybe RealSrcSpan ->
155+ Maybe SpanMark ->
170 Bool
156 Bool
171−needsNewlineBefore l mlastSpn =
157+needsNewlineBefore _ (Just (HaddockSpan _ _)) = True
172− case mlastSpn of
158+needsNewlineBefore l mlastMark =
159+ case spanMarkSpan <$> mlastMark of
173 Nothing -> False
160 Nothing -> False
174− Just lastSpn ->
161+ Just lastMark ->
175− srcSpanStartLine l > srcSpanEndLine lastSpn + 1
162+ srcSpanStartLine l > srcSpanEndLine lastMark + 1
176
163
177-- | Is the preceding comment and AST element are on the same line?
164-- | Is the preceding comment and AST element are on the same line?
178theSameLinePre ::
165theSameLinePre ::
@@ -203,11 +190,11 @@ commentFollowsElt ::
203 -- | Location of enclosing AST element
190 -- | Location of enclosing AST element
204 Maybe RealSrcSpan ->
191 Maybe RealSrcSpan ->
205 -- | Location of last comment in the series
192 -- | Location of last comment in the series
206− Maybe RealSrcSpan ->
193+ Maybe SpanMark ->
207 -- | Comment to test
194 -- | Comment to test
208 RealLocated Comment ->
195 RealLocated Comment ->
209 Bool
196 Bool
210−commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
197+commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =
211 -- A comment follows a AST element if all 4 conditions are satisfied:
198 -- A comment follows a AST element if all 4 conditions are satisfied:
212 goesAfter
199 goesAfter
213 && logicallyFollows
200 && logicallyFollows
@@ -220,9 +207,8 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
220 -- 2) The comment logically belongs to the element, four cases:
207 -- 2) The comment logically belongs to the element, four cases:
221 logicallyFollows =
208 logicallyFollows =
222 theSameLinePost l ref -- a) it's on the same line
209 theSameLinePost l ref -- a) it's on the same line
223− || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
224− || continuation -- c) it's a continuation of a comment block
210+ || continuation -- b) it's a continuation of a comment block
225− || lastInEnclosing -- d) it's the last element in the enclosing construct
211+ || lastInEnclosing -- c) it's the last element in the enclosing construct
226
212
227 -- 3) There is no other AST element between this element and the comment:
213 -- 3) There is no other AST element between this element and the comment:
228 noEltBetween =
214 noEltBetween =
@@ -244,15 +230,20 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
244 Nothing -> True
230 Nothing -> True
245 Just espn ->
231 Just espn ->
246 let startColumn = srcLocCol . realSrcSpanStart
232 let startColumn = srcLocCol . realSrcSpanStart
247− in if startColumn espn > startColumn ref
233+ in startColumn espn > startColumn ref
248− then True
249− else
250− abs (startColumn espn - startColumn l)
234+ || ( abs (startColumn espn - startColumn l)
251− >= abs (startColumn ref - startColumn l)
235+ >= abs (startColumn ref - startColumn l)
236+ )
252 continuation =
237 continuation =
238+ -- A comment is a continuation when it doesn't have non-whitespace
239+ -- lexemes in front of it and goes right after the previous comment.
240+ not (hasAtomsBefore comment)
253− case mlastSpn of
241+ && ( case mlastMark of
254− Nothing -> False
242+ Just (HaddockSpan _ _) -> False
243+ Just (CommentSpan spn) ->
255− Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
244+ srcSpanEndLine spn + 1 == srcSpanStartLine l
245+ _ -> False
246+ )
256 lastInEnclosing =
247 lastInEnclosing =
257 case meSpn of
248 case meSpn of
258 -- When there is no enclosing element, return false
249 -- When there is no enclosing element, return false
@@ -274,9 +265,9 @@ spitCommentNow spn comment = do
274 . sequence_
265 . sequence_
275 . NE.intersperse newline
266 . NE.intersperse newline
276 . fmap (txt . T.pack)
267 . fmap (txt . T.pack)
277− . coerce
268+ . unComment
278 $ comment
269 $ comment
279− setLastCommentSpan Nothing spn
270+ setSpanMark (CommentSpan spn)
280
271
281-- | Output a 'Comment' at the end of correct line or after it depending on
272-- | Output a 'Comment' at the end of correct line or after it depending on
282-- 'CommentPosition'. Used for comments that may potentially follow on the
273-- 'CommentPosition'. Used for comments that may potentially follow on the
@@ -290,6 +281,6 @@ spitCommentPending position spn comment = do
290 . sequence_
281 . sequence_
291 . NE.toList
282 . NE.toList
292 . fmap (registerPendingCommentLine position . T.pack)
283 . fmap (registerPendingCommentLine position . T.pack)
293− . coerce
284+ . unComment
294 $ comment
285 $ comment
295− setLastCommentSpan Nothing spn
286+ setSpanMark (CommentSpan spn)
src/Ormolu/Printer/Internal.hs+173−110
@@ -14,10 +14,11 @@ module Ormolu.Printer.Internal
14
14
15 -- * Internal functions
15 -- * Internal functions
16 txt,
16 txt,
17+ interferingTxt,
17 atom,
18 atom,
18 space,
19 space,
19 newline,
20 newline,
20− isLineDirty,
21+ useRecordDot,
21 inci,
22 inci,
22 sitcc,
23 sitcc,
23 Layout (..),
24 Layout (..),
@@ -38,9 +39,14 @@ module Ormolu.Printer.Internal
38 popComment,
39 popComment,
39 getEnclosingSpan,
40 getEnclosingSpan,
40 withEnclosingSpan,
41 withEnclosingSpan,
42+ thisLineSpans,
43+
44+ -- * Stateful markers
45+ SpanMark (..),
46+ spanMarkSpan,
41 HaddockStyle (..),
47 HaddockStyle (..),
42− setLastCommentSpan,
48+ setSpanMark,
43− getLastCommentSpan,
49+ getSpanMark,
44
50
45 -- * Annotations
51 -- * Annotations
46 getAnns,
52 getAnns,
@@ -62,7 +68,6 @@ import Ormolu.Parser.CommentStream
62import Ormolu.Printer.SpanStream
68import Ormolu.Printer.SpanStream
63import Ormolu.Utils (showOutputable)
69import Ormolu.Utils (showOutputable)
64import Outputable (Outputable)
70import Outputable (Outputable)
65−import SrcLoc
66
71
67----------------------------------------------------------------------------
72----------------------------------------------------------------------------
68-- The 'R' monad
73-- The 'R' monad
@@ -74,43 +79,44 @@ newtype R a = R (ReaderT RC (State SC) a)
74
79
75-- | Reader context of 'R'. This should be used when we control rendering by
80-- | Reader context of 'R'. This should be used when we control rendering by
76-- enclosing certain expressions with wrappers.
81-- enclosing certain expressions with wrappers.
77−data RC
82+data RC = RC
78− = RC
79− { -- | Indentation level, as the column index we need to start from after
83+ { -- | Indentation level, as the column index we need to start from after
80− -- a newline if we break lines
84+ -- a newline if we break lines
81− rcIndent :: !Int,
85+ rcIndent :: !Int,
82− -- | Current layout
86+ -- | Current layout
83− rcLayout :: Layout,
87+ rcLayout :: Layout,
84− -- | Spans of enclosing elements of AST
88+ -- | Spans of enclosing elements of AST
85− rcEnclosingSpans :: [RealSrcSpan],
89+ rcEnclosingSpans :: [RealSrcSpan],
86− -- | Collection of annotations
90+ -- | Collection of annotations
87− rcAnns :: Anns,
91+ rcAnns :: Anns,
88− -- | If the last expression in the layout can use braces
92+ -- | Whether the last expression in the layout can use braces
89− rcCanUseBraces :: Bool
93+ rcCanUseBraces :: Bool,
94+ -- | Whether the source could have used the record dot preprocessor
95+ rcUseRecDot :: Bool
90− }
96+ }
91
97
92-- | State context of 'R'.
98-- | State context of 'R'.
93−data SC
99+data SC = SC
94− = SC
95− { -- | Index of the next column to render
100+ { -- | Index of the next column to render
96− scColumn :: !Int,
101+ scColumn :: !Int,
102+ -- | Indentation level that was used for the current line
103+ scIndent :: !Int,
97− -- | Rendered source code so far
104+ -- | Rendered source code so far
98− scBuilder :: Builder,
105+ scBuilder :: Builder,
99− -- | Span stream
106+ -- | Span stream
100− scSpanStream :: SpanStream,
107+ scSpanStream :: SpanStream,
108+ -- | Spans of atoms that have been printed on the current line so far
109+ scThisLineSpans :: [RealSrcSpan],
101− -- | Comment stream
110+ -- | Comment stream
102− scCommentStream :: CommentStream,
111+ scCommentStream :: CommentStream,
103− -- | Pending comment lines (in reverse order) to be inserted before next
112+ -- | Pending comment lines (in reverse order) to be inserted before next
104− -- newline, 'Int' is the indentation level
113+ -- newline, 'Int' is the indentation level
105− scPendingComments :: ![(CommentPosition, Int, Text)],
114+ scPendingComments :: ![(CommentPosition, Text)],
106− -- | Whether the current line is “dirty”, that is, already contains
107− -- atoms that can have comments attached to them
108− scDirtyLine :: !Bool,
109− -- | Whether to output a space before the next output
115+ -- | Whether to output a space before the next output
110− scRequestedDelimiter :: !RequestedDelimiter,
116+ scRequestedDelimiter :: !RequestedDelimiter,
111− -- | Span of last output comment
117+ -- | An auxiliary marker for keeping track of last output element
112− scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
118+ scSpanMark :: !(Maybe SpanMark)
113− }
119+ }
114
120
115-- | Make sure next output is delimited by one of the following.
121-- | Make sure next output is delimited by one of the following.
116data RequestedDelimiter
122data RequestedDelimiter
@@ -152,32 +158,55 @@ runR ::
152 CommentStream ->
158 CommentStream ->
153 -- | Annotations
159 -- | Annotations
154 Anns ->
160 Anns ->
161+ -- | Use Record Dot Syntax
162+ Bool ->
155 -- | Resulting rendition
163 -- | Resulting rendition
156 Text
164 Text
157−runR (R m) sstream cstream anns =
165+runR (R m) sstream cstream anns recDot =
158 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
166 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
159 where
167 where
160− rc = RC
168+ rc =
169+ RC
161− { rcIndent = 0,
170+ { rcIndent = 0,
162− rcLayout = MultiLine,
171+ rcLayout = MultiLine,
163− rcEnclosingSpans = [],
172+ rcEnclosingSpans = [],
164− rcAnns = anns,
173+ rcAnns = anns,
165− rcCanUseBraces = False
174+ rcCanUseBraces = False,
175+ rcUseRecDot = recDot
166− }
176+ }
167− sc = SC
177+ sc =
178+ SC
168− { scColumn = 0,
179+ { scColumn = 0,
180+ scIndent = 0,
169− scBuilder = mempty,
181+ scBuilder = mempty,
170− scSpanStream = sstream,
182+ scSpanStream = sstream,
183+ scThisLineSpans = [],
171− scCommentStream = cstream,
184+ scCommentStream = cstream,
172− scPendingComments = [],
185+ scPendingComments = [],
173− scDirtyLine = False,
174− scRequestedDelimiter = VeryBeginning,
186+ scRequestedDelimiter = VeryBeginning,
175− scLastCommentSpan = Nothing
187+ scSpanMark = Nothing
176− }
188+ }
177
189
178----------------------------------------------------------------------------
190----------------------------------------------------------------------------
179-- Internal functions
191-- Internal functions
180
192
193+-- | Type of the thing to output. Influences the primary low-level rendering
194+-- function 'spit'.
195+data SpitType
196+ = -- | Simple opaque text that breaks comment series.
197+ SimpleText
198+ | -- | Like 'SimpleText', but assume that when this text is inserted it
199+ -- will separate an 'Atom' and its pending comments, so insert an extra
200+ -- 'newline' in that case to force the pending comments and continue on
201+ -- a fresh line.
202+ InterferingText
203+ | -- | An atom that typically have span information in the AST and can
204+ -- have comments attached to it.
205+ Atom
206+ | -- | Used for rendering comment lines.
207+ CommentPart
208+ deriving (Show, Eq)
209+
181-- | Output a fixed 'Text' fragment. The argument may not contain any line
210-- | Output a fixed 'Text' fragment. The argument may not contain any line
182-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
211-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
183-- keywords and pipes @|@ in functional dependencies.
212-- keywords and pipes @|@ in functional dependencies.
@@ -189,7 +218,15 @@ txt ::
189 -- | 'Text' to output
218 -- | 'Text' to output
190 Text ->
219 Text ->
191 R ()
220 R ()
192−txt = spit False False
221+txt = spit SimpleText
222+
223+-- | Similar to 'txt' but the text inserted this way is assumed to break the
224+-- “link” between the preceding atom and its pending comments.
225+interferingTxt ::
226+ -- | 'Text' to output
227+ Text ->
228+ R ()
229+interferingTxt = spit InterferingText
193
230
194-- | Output 'Outputable' fragment of AST. This can be used to output numeric
231-- | Output 'Outputable' fragment of AST. This can be used to output numeric
195-- literals and similar. Everything that doesn't have inner structure but
232-- literals and similar. Everything that doesn't have inner structure but
@@ -198,48 +235,61 @@ atom ::
198 Outputable a =>
235 Outputable a =>
199 a ->
236 a ->
200 R ()
237 R ()
201−atom = spit True False . T.pack . showOutputable
238+atom = spit Atom . T.pack . showOutputable
202
239
203-- | Low-level non-public helper to define 'txt' and 'atom'.
240-- | Low-level non-public helper to define 'txt' and 'atom'.
204spit ::
241spit ::
205− -- | Should we mark the line as dirty?
242+ -- | Type of the thing to spit
206− Bool ->
243+ SpitType ->
207− -- | Used during outputting of pending comments?
208− Bool ->
209 -- | 'Text' to output
244 -- | 'Text' to output
210 Text ->
245 Text ->
211 R ()
246 R ()
212−spit dirty printingComments txt' = do
247+spit _ "" = return ()
248+spit stype text = do
213 requestedDel <- R (gets scRequestedDelimiter)
249 requestedDel <- R (gets scRequestedDelimiter)
250+ pendingComments <- R (gets scPendingComments)
251+ when (stype == InterferingText && not (null pendingComments)) newline
214 case requestedDel of
252 case requestedDel of
215 RequestedNewline -> do
253 RequestedNewline -> do
216 R . modify $ \sc ->
254 R . modify $ \sc ->
217 sc
255 sc
218 { scRequestedDelimiter = RequestedNothing
256 { scRequestedDelimiter = RequestedNothing
219 }
257 }
220− if printingComments
258+ case stype of
221− then newlineRaw
259+ CommentPart -> newlineRaw
222− else newline
260+ _ -> newline
223 _ -> return ()
261 _ -> return ()
224 R $ do
262 R $ do
225 i <- asks rcIndent
263 i <- asks rcIndent
226 c <- gets scColumn
264 c <- gets scColumn
265+ closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans
227− let spaces =
266+ let indentedTxt = spaces <> text
267+ spaces = T.replicate spacesN " "
268+ spacesN =
228− if c < i
269+ if c == 0
229− then T.replicate (i - c) " "
270+ then i
230− else bool mempty " " (requestedDel == RequestedSpace)
271+ else bool 0 1 (requestedDel == RequestedSpace)
231− indentedTxt = spaces <> txt'
232 modify $ \sc ->
272 modify $ \sc ->
233 sc
273 sc
234 { scBuilder = scBuilder sc <> fromText indentedTxt,
274 { scBuilder = scBuilder sc <> fromText indentedTxt,
235 scColumn = scColumn sc + T.length indentedTxt,
275 scColumn = scColumn sc + T.length indentedTxt,
236− scDirtyLine = scDirtyLine sc || dirty,
276+ scIndent =
277+ if c == 0
278+ then i
279+ else scIndent sc,
280+ scThisLineSpans =
281+ let xs = scThisLineSpans sc
282+ in case stype of
283+ Atom -> case closestEnclosing of
284+ Nothing -> xs
285+ Just x -> x : xs
286+ _ -> xs,
237 scRequestedDelimiter = RequestedNothing,
287 scRequestedDelimiter = RequestedNothing,
238− scLastCommentSpan =
288+ scSpanMark =
239− -- NOTE If there are pending comments, do not reset last comment
289+ -- If there are pending comments, do not reset last comment
240 -- location.
290 -- location.
241− if printingComments || (not . null . scPendingComments) sc
291+ if (stype == CommentPart) || (not . null . scPendingComments) sc
242− then scLastCommentSpan sc
292+ then scSpanMark sc
243 else Nothing
293 else Nothing
244 }
294 }
245
295
@@ -270,21 +320,22 @@ space = R . modify $ \sc ->
270-- hard to output more than one blank newline in a row.
320-- hard to output more than one blank newline in a row.
271newline :: R ()
321newline :: R ()
272newline = do
322newline = do
323+ indent <- R (gets scIndent)
273 cs <- reverse <$> R (gets scPendingComments)
324 cs <- reverse <$> R (gets scPendingComments)
274 case cs of
325 case cs of
275 [] -> newlineRaw
326 [] -> newlineRaw
276− ((position, _, _) : _) -> do
327+ ((position, _) : _) -> do
277 case position of
328 case position of
278 OnTheSameLine -> space
329 OnTheSameLine -> space
279 OnNextLine -> newlineRaw
330 OnNextLine -> newlineRaw
280− R . forM_ cs $ \(_, indent, txt') ->
331+ R . forM_ cs $ \(_, text) ->
281 let modRC rc =
332 let modRC rc =
282 rc
333 rc
283 { rcIndent = indent
334 { rcIndent = indent
284 }
335 }
285 R m = do
336 R m = do
286− unless (T.null txt') $
337+ unless (T.null text) $
287− spit False True txt'
338+ spit CommentPart text
288 newlineRaw
339 newlineRaw
289 in local modRC m
340 in local modRC m
290 R . modify $ \sc ->
341 R . modify $ \sc ->
@@ -305,7 +356,8 @@ newlineRaw = R . modify $ \sc ->
305 VeryBeginning -> builderSoFar
356 VeryBeginning -> builderSoFar
306 _ -> builderSoFar <> "\n",
357 _ -> builderSoFar <> "\n",
307 scColumn = 0,
358 scColumn = 0,
308− scDirtyLine = False,
359+ scIndent = 0,
360+ scThisLineSpans = [],
309 scRequestedDelimiter = case scRequestedDelimiter sc of
361 scRequestedDelimiter = case scRequestedDelimiter sc of
310 AfterNewline -> RequestedNewline
362 AfterNewline -> RequestedNewline
311 RequestedNewline -> RequestedNewline
363 RequestedNewline -> RequestedNewline
@@ -313,10 +365,9 @@ newlineRaw = R . modify $ \sc ->
313 _ -> AfterNewline
365 _ -> AfterNewline
314 }
366 }
315
367
316−-- | Check if the current line is “dirty”, that is, there is something on it
368+-- | Return 'True' if we should print record dot syntax.
317−-- that can have comments attached to it.
369+useRecordDot :: R Bool
318−isLineDirty :: R Bool
370+useRecordDot = R (asks rcUseRecDot)
319−isLineDirty = R (gets scDirtyLine)
320
371
321-- | Increase indentation level by one indentation step for the inner
372-- | Increase indentation level by one indentation step for the inner
322-- computation. 'inci' should be used when a part of code must be more
373-- computation. 'inci' should be used when a part of code must be more
@@ -333,8 +384,7 @@ inci (R m) = R (local modRC m)
333
384
334-- | Set indentation level for the inner computation equal to current
385-- | Set indentation level for the inner computation equal to current
335-- column. This makes sure that the entire inner block is uniformly
386-- column. This makes sure that the entire inner block is uniformly
336−-- \"shifted\" to the right. Only works (and makes sense) when enclosing
387+-- \"shifted\" to the right.
337−-- layout is multi-line.
338sitcc :: R () -> R ()
388sitcc :: R () -> R ()
339sitcc (R m) = do
389sitcc (R m) = do
340 requestedDel <- R (gets scRequestedDelimiter)
390 requestedDel <- R (gets scRequestedDelimiter)
@@ -342,16 +392,9 @@ sitcc (R m) = do
342 c <- R (gets scColumn)
392 c <- R (gets scColumn)
343 let modRC rc =
393 let modRC rc =
344 rc
394 rc
345− { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
395+ { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))
346 }
396 }
347− vlayout (R m) . R $ do
348− modify $ \sc ->
349− sc
350− { scRequestedDelimiter = case requestedDel of
351− RequestedSpace -> RequestedNothing
352− other -> other
353− }
354− local modRC m
397+ R (local modRC m)
355
398
356-- | Set 'Layout' for internal computation.
399-- | Set 'Layout' for internal computation.
357enterLayout :: Layout -> R () -> R ()
400enterLayout :: Layout -> R () -> R ()
@@ -392,11 +435,10 @@ registerPendingCommentLine ::
392 -- | 'Text' to output
435 -- | 'Text' to output
393 Text ->
436 Text ->
394 R ()
437 R ()
395−registerPendingCommentLine position txt' = R $ do
438+registerPendingCommentLine position text = R $ do
396− i <- asks rcIndent
397 modify $ \sc ->
439 modify $ \sc ->
398 sc
440 sc
399− { scPendingComments = (position, i, txt') : scPendingComments sc
441+ { scPendingComments = (position, text) : scPendingComments sc
400 }
442 }
401
443
402-- | Drop elements that begin before or at the same place as given
444-- | Drop elements that begin before or at the same place as given
@@ -455,6 +497,29 @@ withEnclosingSpan spn (R m) = R (local modRC m)
455 { rcEnclosingSpans = spn : rcEnclosingSpans rc
497 { rcEnclosingSpans = spn : rcEnclosingSpans rc
456 }
498 }
457
499
500+-- | Get spans on this line so far.
501+thisLineSpans :: R [RealSrcSpan]
502+thisLineSpans = R (gets scThisLineSpans)
503+
504+----------------------------------------------------------------------------
505+-- Stateful markers
506+
507+-- | An auxiliary marker for keeping track of last output element.
508+data SpanMark
509+ = -- | Haddock comment
510+ HaddockSpan HaddockStyle RealSrcSpan
511+ | -- | Non-haddock comment
512+ CommentSpan RealSrcSpan
513+ | -- | A statement in a do-block and such span
514+ StatementSpan RealSrcSpan
515+
516+-- | Project 'RealSrcSpan' from 'SpanMark'.
517+spanMarkSpan :: SpanMark -> RealSrcSpan
518+spanMarkSpan = \case
519+ HaddockSpan _ s -> s
520+ CommentSpan s -> s
521+ StatementSpan s -> s
522+
458-- | Haddock string style.
523-- | Haddock string style.
459data HaddockStyle
524data HaddockStyle
460 = -- | @-- |@
525 = -- | @-- |@
@@ -467,20 +532,18 @@ data HaddockStyle
467 Named String
532 Named String
468
533
469-- | Set span of last output comment.
534-- | Set span of last output comment.
470−setLastCommentSpan ::
535+setSpanMark ::
471− -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
536+ -- | Span mark to set
472− Maybe HaddockStyle ->
537+ SpanMark ->
473− -- | Location of last printed comment
474− RealSrcSpan ->
475 R ()
538 R ()
476−setLastCommentSpan mhStyle spn = R . modify $ \sc ->
539+setSpanMark spnMark = R . modify $ \sc ->
477 sc
540 sc
478− { scLastCommentSpan = Just (mhStyle, spn)
541+ { scSpanMark = Just spnMark
479 }
542 }
480
543
481-- | Get span of last output comment.
544-- | Get span of last output comment.
482−getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
545+getSpanMark :: R (Maybe SpanMark)
483−getLastCommentSpan = R (gets scLastCommentSpan)
546+getSpanMark = R (gets scSpanMark)
484
547
485----------------------------------------------------------------------------
548----------------------------------------------------------------------------
486-- Annotations
549-- Annotations
@@ -504,7 +567,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
504
567
505-- | Return 'True' if we can use braces in this context.
568-- | Return 'True' if we can use braces in this context.
506canUseBraces :: R Bool
569canUseBraces :: R Bool
507−canUseBraces = R $ asks rcCanUseBraces
570+canUseBraces = R (asks rcCanUseBraces)
508
571
509----------------------------------------------------------------------------
572----------------------------------------------------------------------------
510-- Constants
573-- Constants
src/Ormolu/Printer/Meat/Common.hs+25−22
@@ -17,14 +17,12 @@ where
17
17
18import Control.Monad
18import Control.Monad
19import Data.List (isPrefixOf)
19import Data.List (isPrefixOf)
20−import Data.Maybe (isJust)
21import qualified Data.Text as T
20import qualified Data.Text as T
22import GHC hiding (GhcPs, IE)
21import GHC hiding (GhcPs, IE)
23import Name (nameStableString)
22import Name (nameStableString)
24import OccName (OccName (..))
23import OccName (OccName (..))
25import Ormolu.Printer.Combinators
24import Ormolu.Printer.Combinators
26import Ormolu.Utils
25import Ormolu.Utils
27−import RdrName (RdrName (..))
28
26
29-- | Data and type family style.
27-- | Data and type family style.
30data FamilyStyle
28data FamilyStyle
@@ -76,10 +74,10 @@ p_rdrName l@(L spn _) = located l $ \x -> do
76 Qual mname occName ->
74 Qual mname occName ->
77 p_qualName mname occName
75 p_qualName mname occName
78 Orig _ occName ->
76 Orig _ occName ->
79− -- NOTE This is used when GHC generates code that will be fed
77+ -- This is used when GHC generates code that will be fed into
80− -- into the renamer (e.g. from deriving clauses), but where we
78+ -- the renamer (e.g. from deriving clauses), but where we want
81− -- want to say that something comes from given module which is
79+ -- to say that something comes from given module which is not
82− -- not specified in the source code, e.g. @Prelude.map@.
80+ -- specified in the source code, e.g. @Prelude.map@.
83 --
81 --
84 -- My current understanding is that the provided module name
82 -- My current understanding is that the provided module name
85 -- serves no purpose for us and can be safely ignored.
83 -- serves no purpose for us and can be safely ignored.
@@ -99,9 +97,9 @@ doesNotNeedExtraParens :: RdrName -> Bool
99doesNotNeedExtraParens = \case
97doesNotNeedExtraParens = \case
100 Exact name ->
98 Exact name ->
101 let s = nameStableString name
99 let s = nameStableString name
102− in -- NOTE I'm not sure this "stable string" is stable enough, but it looks
100+ in -- I'm not sure this "stable string" is stable enough, but it looks
103− -- like this is the most robust way to tell if we're looking at exactly
101+ -- like this is the most robust way to tell if we're looking at
104− -- this piece of built-in syntax.
102+ -- exactly this piece of built-in syntax.
105 ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
103 ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
106 || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
104 || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
107 _ -> False
105 _ -> False
@@ -116,14 +114,14 @@ p_qualName mname occName = do
116p_infixDefHelper ::
114p_infixDefHelper ::
117 -- | Whether to format in infix style
115 -- | Whether to format in infix style
118 Bool ->
116 Bool ->
119− -- | Indentation-bumping wrapper
117+ -- | Whether to bump indentation for arguments
120− (R () -> R ()) ->
118+ Bool ->
121 -- | How to print the operator\/name
119 -- | How to print the operator\/name
122 R () ->
120 R () ->
123 -- | How to print the arguments
121 -- | How to print the arguments
124 [R ()] ->
122 [R ()] ->
125 R ()
123 R ()
126−p_infixDefHelper isInfix inci' name args =
124+p_infixDefHelper isInfix indentArgs name args =
127 case (isInfix, args) of
125 case (isInfix, args) of
128 (True, p0 : p1 : ps) -> do
126 (True, p0 : p1 : ps) -> do
129 let parens' =
127 let parens' =
@@ -133,18 +131,18 @@ p_infixDefHelper isInfix inci' name args =
133 parens' $ do
131 parens' $ do
134 p0
132 p0
135 breakpoint
133 breakpoint
136− inci $ sitcc $ do
134+ inci . sitcc $ do
137 name
135 name
138 space
136 space
139 p1
137 p1
140− unless (null ps) . inci' $ do
138+ unless (null ps) . inciIf indentArgs $ do
141 breakpoint
139 breakpoint
142 sitcc (sep breakpoint sitcc ps)
140 sitcc (sep breakpoint sitcc ps)
143 (_, ps) -> do
141 (_, ps) -> do
144 name
142 name
145 unless (null ps) $ do
143 unless (null ps) $ do
146 breakpoint
144 breakpoint
147− inci' $ sitcc (sep breakpoint sitcc args)
145+ inciIf indentArgs $ sitcc (sep breakpoint sitcc args)
148
146
149-- | Print a Haddock.
147-- | Print a Haddock.
150p_hsDocString ::
148p_hsDocString ::
@@ -156,17 +154,22 @@ p_hsDocString ::
156 LHsDocString ->
154 LHsDocString ->
157 R ()
155 R ()
158p_hsDocString hstyle needsNewline (L l str) = do
156p_hsDocString hstyle needsNewline (L l str) = do
159− goesAfterComment <- isJust <$> getLastCommentSpan
157+ let isCommentSpan = \case
158+ HaddockSpan _ _ -> True
159+ CommentSpan _ -> True
160+ _ -> False
161+ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark
160 -- Make sure the Haddock is separated by a newline from other comments.
162 -- Make sure the Haddock is separated by a newline from other comments.
161 when goesAfterComment newline
163 when goesAfterComment newline
162 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do
164 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do
163 if isFirst
165 if isFirst
164 then case hstyle of
166 then case hstyle of
165− Pipe -> txt "-- |" >> space
167+ Pipe -> txt "-- |"
166− Caret -> txt "-- ^" >> space
168+ Caret -> txt "-- ^"
167− Asterisk n -> txt ("-- " <> T.replicate n "*") >> space
169+ Asterisk n -> txt ("-- " <> T.replicate n "*")
168 Named name -> p_hsDocName name
170 Named name -> p_hsDocName name
169− else newline >> txt "--" >> space
171+ else newline >> txt "--"
172+ space
170 unless (T.null x) (txt x)
173 unless (T.null x) (txt x)
171 when needsNewline newline
174 when needsNewline newline
172 case l of
175 case l of
@@ -174,8 +177,8 @@ p_hsDocString hstyle needsNewline (L l str) = do
174 -- It's often the case that the comment itself doesn't have a span
177 -- It's often the case that the comment itself doesn't have a span
175 -- attached to it and instead its location can be obtained from
178 -- attached to it and instead its location can be obtained from
176 -- nearest enclosing span.
179 -- nearest enclosing span.
177− getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))
180+ getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)
178− RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
181+ RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)
179
182
180-- | Print anchor of named doc section.
183-- | Print anchor of named doc section.
181p_hsDocName :: String -> R ()
184p_hsDocName :: String -> R ()
src/Ormolu/Printer/Meat/Declaration.hs+176−111
@@ -7,14 +7,14 @@
7-- | Rendering of declarations.
7-- | Rendering of declarations.
8module Ormolu.Printer.Meat.Declaration
8module Ormolu.Printer.Meat.Declaration
9 ( p_hsDecls,
9 ( p_hsDecls,
10− hasSeparatedDecls,
10+ p_hsDeclsRespectGrouping,
11 )
11 )
12where
12where
13
13
14import Data.List (sort)
14import Data.List (sort)
15−import Data.List.NonEmpty ((<|), NonEmpty (..))
15+import Data.List.NonEmpty (NonEmpty (..), (<|))
16import qualified Data.List.NonEmpty as NE
16import qualified Data.List.NonEmpty as NE
17−import GHC
17+import GHC hiding (InlinePragma)
18import OccName (occNameFS)
18import OccName (occNameFS)
19import Ormolu.Printer.Combinators
19import Ormolu.Printer.Combinators
20import Ormolu.Printer.Meat.Common
20import Ormolu.Printer.Meat.Common
@@ -34,25 +34,57 @@ import Ormolu.Printer.Meat.Declaration.Value
34import Ormolu.Printer.Meat.Declaration.Warning
34import Ormolu.Printer.Meat.Declaration.Warning
35import Ormolu.Printer.Meat.Type
35import Ormolu.Printer.Meat.Type
36import Ormolu.Utils
36import Ormolu.Utils
37−import RdrName (rdrNameOcc)
37+
38+data UserGrouping
39+ = -- | Always put newlines where we think they should be
40+ Disregard
41+ | -- | Respect user preferences regarding grouping
42+ Respect
43+ deriving (Eq, Show)
38
44
39p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
45p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
46+p_hsDecls = p_hsDecls' Disregard
47+
48+-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the
49+-- user omits newlines between declarations, we also omit them in most
50+-- cases, except when said declarations have associated Haddocks.
51+--
52+-- Does some normalization (compress subsequent newlines into a single one)
53+p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
54+p_hsDeclsRespectGrouping = p_hsDecls' Respect
55+
56+p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
57+p_hsDecls' grouping style decls =
40−p_hsDecls style decls = sepSemi id $
58+ sepSemi id $
41− -- Return a list of rendered declarations, adding a newline to separate
59+ -- Return a list of rendered declarations, adding a newline to separate
42− -- groups.
60+ -- groups.
43− case groupDecls decls of
61+ case groupDecls decls of
44− [] -> []
62+ [] -> []
45− (x : xs) ->
63+ (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
46− NE.toList (renderGroup x)
47− ++ concatMap (NE.toList . separateGroup . renderGroup) xs
48 where
64 where
49− renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style)
65+ renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
50− separateGroup (x :| xs) = (breakpoint' >> x) :| xs
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
70+ Disregard ->
71+ breakpoint : renderGroup curr
72+ Respect ->
73+ if separatedByBlankNE getLoc prev curr
74+ || isDocumented prev
75+ || isDocumented curr
76+ then breakpoint : renderGroup curr
77+ else renderGroup curr
78+
79+-- | Is a declaration group documented?
80+isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
81+isDocumented = any (isHaddock . unLoc)
82+ where
83+ isHaddock DocNext = True
84+ isHaddock DocPrev = True
85+ isHaddock _ = False
51
86
52-- | Group relevant declarations together.
87-- | Group relevant declarations together.
53−--
54−-- Add a declaration to a group iff it is relevant to either the first or
55−-- the last declaration of the group.
56groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
88groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
57groupDecls [] = []
89groupDecls [] = []
58groupDecls (l@(L _ DocNext) : xs) =
90groupDecls (l@(L _ DocNext) : xs) =
@@ -61,44 +93,40 @@ groupDecls (l@(L _ DocNext) : xs) =
61 case groupDecls xs of
93 case groupDecls xs of
62 [] -> [l :| []]
94 [] -> [l :| []]
63 (x : xs') -> (l <| x) : xs'
95 (x : xs') -> (l <| x) : xs'
64−groupDecls (lhdr : xs) =
96+groupDecls (header : xs) =
65− let -- Pick the first decl as the group header
97+ let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->
66− hdr = unLoc lhdr
67− -- Zip rest of the decls with their previous decl
68− zipped = zip (lhdr : xs) xs
69− -- Pick decls from the tail if they are relevant to the group header
70− -- or the previous decl.
71− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
72− let relevantToHdr = groupedDecls hdr cur
98+ let relevantToHdr = groupedDecls header current
73− relevantToPrev = groupedDecls prev cur
99+ relevantToPrev = groupedDecls previous current
100+ isDeclSeries = declSeries previous current
74− in relevantToHdr || relevantToPrev
101+ in isDeclSeries || relevantToHdr || relevantToPrev
75− in (lhdr :| map snd grp) : groupDecls (map snd rest)
102+ in (header :| map snd grp) : groupDecls (map snd rest)
76
103
77p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
104p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
78p_hsDecl style = \case
105p_hsDecl style = \case
79− TyClD NoExt x -> p_tyClDecl style x
106+ TyClD NoExtField x -> p_tyClDecl style x
80− ValD NoExt x -> p_valDecl x
107+ ValD NoExtField x -> p_valDecl x
81− SigD NoExt x -> p_sigDecl x
108+ SigD NoExtField x -> p_sigDecl x
82− InstD NoExt x -> p_instDecl style x
109+ InstD NoExtField x -> p_instDecl style x
83− DerivD NoExt x -> p_derivDecl x
110+ DerivD NoExtField x -> p_derivDecl x
84− DefD NoExt x -> p_defaultDecl x
111+ DefD NoExtField x -> p_defaultDecl x
85− ForD NoExt x -> p_foreignDecl x
112+ ForD NoExtField x -> p_foreignDecl x
86− WarningD NoExt x -> p_warnDecls x
113+ WarningD NoExtField x -> p_warnDecls x
87− AnnD NoExt x -> p_annDecl x
114+ AnnD NoExtField x -> p_annDecl x
88− RuleD NoExt x -> p_ruleDecls x
115+ RuleD NoExtField x -> p_ruleDecls x
89− SpliceD NoExt x -> p_spliceDecl x
116+ SpliceD NoExtField x -> p_spliceDecl x
90− DocD NoExt docDecl ->
117+ DocD NoExtField docDecl ->
91 case docDecl of
118 case docDecl of
92 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
119 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
93 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
120 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
94 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
121 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
95 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
122 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
96− RoleAnnotD NoExt x -> p_roleAnnot x
123+ RoleAnnotD NoExtField x -> p_roleAnnot x
97− XHsDecl _ -> notImplemented "XHsDecl"
124+ KindSigD NoExtField s -> p_standaloneKindSig s
125+ XHsDecl x -> noExtCon x
98
126
99p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
127p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
100p_tyClDecl style = \case
128p_tyClDecl style = \case
101− FamDecl NoExt x -> p_famDecl style x
129+ FamDecl NoExtField x -> p_famDecl style x
102 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
130 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
103 DataDecl {..} ->
131 DataDecl {..} ->
104 p_dataDecl
132 p_dataDecl
@@ -119,39 +147,65 @@ p_tyClDecl style = \case
119 tcdATs
147 tcdATs
120 tcdATDefs
148 tcdATDefs
121 tcdDocs
149 tcdDocs
122− XTyClDecl {} -> notImplemented "XTyClDecl"
150+ XTyClDecl x -> noExtCon x
123
151
124p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
152p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
125p_instDecl style = \case
153p_instDecl style = \case
126− ClsInstD NoExt x -> p_clsInstDecl x
154+ ClsInstD NoExtField x -> p_clsInstDecl x
127− TyFamInstD NoExt x -> p_tyFamInstDecl style x
155+ TyFamInstD NoExtField x -> p_tyFamInstDecl style x
128− DataFamInstD NoExt x -> p_dataFamInstDecl style x
156+ DataFamInstD NoExtField x -> p_dataFamInstDecl style x
129− XInstDecl _ -> notImplemented "XInstDecl"
157+ XInstDecl x -> noExtCon x
130
158
131p_derivDecl :: DerivDecl GhcPs -> R ()
159p_derivDecl :: DerivDecl GhcPs -> R ()
132p_derivDecl = \case
160p_derivDecl = \case
133− d@DerivDecl {..} -> p_standaloneDerivDecl d
161+ d@DerivDecl {} -> p_standaloneDerivDecl d
134− XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
162+ XDerivDecl x -> noExtCon x
135
163
136-- | Determine if these declarations should be grouped together.
164-- | Determine if these declarations should be grouped together.
137groupedDecls ::
165groupedDecls ::
138− HsDecl GhcPs ->
166+ LHsDecl 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 ->
139− HsDecl GhcPs ->
201+ LHsDecl GhcPs ->
140 Bool
202 Bool
141−groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
203+declSeries (L _ x) (L _ y) =
142−groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
204+ case (x, y) of
143−groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
205+ ( SigD NoExtField (TypeSig NoExtField _ _),
144−groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
206+ SigD NoExtField (TypeSig NoExtField _ _)
145−groupedDecls (DataDeclaration n) x
207+ ) -> True
146− | Just ns <- isPragma x =
147− let f = occNameFS . rdrNameOcc in f n `elem` map f ns
148−groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
149−groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
150−groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'
151−groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns
152−groupedDecls DocNext _ = True
153−groupedDecls _ DocPrev = True
154−groupedDecls _ _ = False
208+ _ -> False
155
209
156intersects :: Ord a => [a] -> [a] -> Bool
210intersects :: Ord a => [a] -> [a] -> Bool
157intersects a b = go (sort a) (sort b)
211intersects a b = go (sort a) (sort b)
@@ -164,13 +218,6 @@ intersects a b = go (sort a) (sort b)
164 | x > y = go (x : xs) ys
218 | x > y = go (x : xs) ys
165 | otherwise = True
219 | otherwise = True
166
220
167−-- | Checks if given list of declarations contain a pair which should
168−-- be separated by a blank line.
169−hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
170−hasSeparatedDecls xs = case groupDecls xs of
171− _ : _ : _ -> True
172− _ -> False
173−
174isPragma ::
221isPragma ::
175 HsDecl GhcPs ->
222 HsDecl GhcPs ->
176 Maybe [RdrName]
223 Maybe [RdrName]
@@ -183,6 +230,11 @@ isPragma = \case
183 WarningPragma n -> Just n
230 WarningPragma n -> Just n
184 _ -> Nothing
231 _ -> Nothing
185
232
233+-- Declarations that do not refer to names
234+
235+pattern Splice :: HsDecl GhcPs
236+pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)
237+
186-- Declarations referring to a single name
238-- Declarations referring to a single name
187
239
188pattern
240pattern
@@ -192,71 +244,84 @@ pattern
192 AnnTypePragma,
244 AnnTypePragma,
193 AnnValuePragma,
245 AnnValuePragma,
194 Pattern,
246 Pattern,
195− DataDeclaration ::
247+ DataDeclaration,
248+ ClassDeclaration,
249+ KindSignature,
250+ FamilyDeclaration ::
196 RdrName -> HsDecl GhcPs
251 RdrName -> HsDecl GhcPs
197−pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
252+pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)
198−pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
253+pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)
199−pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
254+pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)
200−pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
255+pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)
201−pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
256+pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)
202−pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
257+pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))
203−pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
258+pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (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) _ _ _ _))
204
262
205-- Declarations which can refer to multiple names
263-- Declarations which can refer to multiple names
206
264
207pattern
265pattern
208 TypeSignature,
266 TypeSignature,
267+ DefaultSignature,
209 FunctionBody,
268 FunctionBody,
210 PatternSignature,
269 PatternSignature,
211 WarningPragma ::
270 WarningPragma ::
212 [RdrName] -> HsDecl GhcPs
271 [RdrName] -> HsDecl GhcPs
213pattern TypeSignature n <- (sigRdrNames -> Just n)
272pattern TypeSignature n <- (sigRdrNames -> Just n)
273+pattern DefaultSignature n <- (defSigRdrNames -> Just n)
214pattern FunctionBody n <- (funRdrNames -> Just n)
274pattern FunctionBody n <- (funRdrNames -> Just n)
215pattern PatternSignature n <- (patSigRdrNames -> Just n)
275pattern PatternSignature n <- (patSigRdrNames -> Just n)
216pattern WarningPragma n <- (warnSigRdrNames -> Just n)
276pattern WarningPragma n <- (warnSigRdrNames -> Just n)
217
277
218pattern DocNext, DocPrev :: HsDecl GhcPs
278pattern DocNext, DocPrev :: HsDecl GhcPs
219−pattern DocNext <- (DocD NoExt (DocCommentNext _))
279+pattern DocNext <- (DocD NoExtField (DocCommentNext _))
220−pattern DocPrev <- (DocD NoExt (DocCommentPrev _))
280+pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))
221
281
222sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
282sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
223−sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns
283+sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns
224−sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns
284+sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns
225−sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
285+sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
226sigRdrNames _ = Nothing
286sigRdrNames _ = Nothing
227
287
288+defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
289+defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns
290+defSigRdrNames _ = Nothing
291+
228funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
292funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
229−funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
293+funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]
230−funRdrNames (ValD NoExt (PatBind NoExt (L _ n) _ _)) = Just $ patBindNames n
294+funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n
231funRdrNames _ = Nothing
295funRdrNames _ = Nothing
232
296
233patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
297patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
234−patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
298+patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
235patSigRdrNames _ = Nothing
299patSigRdrNames _ = Nothing
236
300
237warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
301warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
238−warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
302+warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $
303+ flip concatMap ws $ \case
239− L _ (Warning NoExt ns _) -> map unLoc ns
304+ L _ (Warning NoExtField ns _) -> map unLoc ns
240− L _ (XWarnDecl NoExt) -> []
305+ L _ (XWarnDecl x) -> noExtCon x
241warnSigRdrNames _ = Nothing
306warnSigRdrNames _ = Nothing
242
307
243patBindNames :: Pat GhcPs -> [RdrName]
308patBindNames :: Pat GhcPs -> [RdrName]
244−patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps
309+patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps
245−patBindNames (VarPat NoExt (L _ n)) = [n]
310+patBindNames (VarPat NoExtField (L _ n)) = [n]
246−patBindNames (WildPat NoExt) = []
311+patBindNames (WildPat NoExtField) = []
247−patBindNames (LazyPat NoExt (L _ p)) = patBindNames p
312+patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p
248−patBindNames (BangPat NoExt (L _ p)) = patBindNames p
313+patBindNames (BangPat NoExtField (L _ p)) = patBindNames p
249−patBindNames (ParPat NoExt (L _ p)) = patBindNames p
314+patBindNames (ParPat NoExtField (L _ p)) = patBindNames p
250−patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
315+patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps
251−patBindNames (AsPat NoExt (L _ n) (L _ p)) = n : patBindNames p
316+patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p
252−patBindNames (SumPat NoExt (L _ p) _ _) = patBindNames p
317+patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p
253−patBindNames (ViewPat NoExt _ (L _ p)) = patBindNames p
318+patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p
254−patBindNames (SplicePat NoExt _) = []
319+patBindNames (SplicePat NoExtField _) = []
255−patBindNames (LitPat NoExt _) = []
320+patBindNames (LitPat NoExtField _) = []
256−patBindNames (SigPat _ (L _ p)) = patBindNames p
321+patBindNames (SigPat _ (L _ p) _) = patBindNames p
257−patBindNames (NPat NoExt _ _ _) = []
322+patBindNames (NPat NoExtField _ _ _) = []
258−patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]
323+patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]
259patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
324patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
260−patBindNames (ConPatOut _ _ _ _ _ _ _) = notImplemented "ConPatOut" -- created by renamer
325+patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
261−patBindNames (CoPat NoExt _ p _) = patBindNames p
326+patBindNames (CoPat NoExtField _ p _) = patBindNames p
262−patBindNames (XPat NoExt) = notImplemented "XPat"
327+patBindNames (XPat x) = noExtCon x
src/Ormolu/Printer/Meat/Declaration.hs-boot+2−3
@@ -1,6 +1,6 @@
1module Ormolu.Printer.Meat.Declaration
1module Ormolu.Printer.Meat.Declaration
2 ( p_hsDecls,
2 ( p_hsDecls,
3− hasSeparatedDecls,
3+ p_hsDeclsRespectGrouping,
4 )
4 )
5where
5where
6
6
@@ -9,5 +9,4 @@ import Ormolu.Printer.Combinators
9import Ormolu.Printer.Meat.Common
9import Ormolu.Printer.Meat.Common
10
10
11p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
11p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12−
12+p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
13−hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
src/Ormolu/Printer/Meat/Declaration/Annotation.hs+2−3
@@ -10,15 +10,14 @@ import GHC
10import Ormolu.Printer.Combinators
10import Ormolu.Printer.Combinators
11import Ormolu.Printer.Meat.Common
11import Ormolu.Printer.Meat.Common
12import Ormolu.Printer.Meat.Declaration.Value
12import Ormolu.Printer.Meat.Declaration.Value
13−import Ormolu.Utils
14
13
15p_annDecl :: AnnDecl GhcPs -> R ()
14p_annDecl :: AnnDecl GhcPs -> R ()
16p_annDecl = \case
15p_annDecl = \case
17− HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do
16+ HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do
18 p_annProv annProv
17 p_annProv annProv
19 breakpoint
18 breakpoint
20 located expr p_hsExpr
19 located expr p_hsExpr
21− XAnnDecl {} -> notImplemented "XAnnDecl"
20+ XAnnDecl x -> noExtCon x
22
21
23p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
22p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
24p_annProv = \case
23p_annProv = \case
src/Ormolu/Printer/Meat/Declaration/Class.hs+26−38
@@ -12,15 +12,12 @@ import Class
12import Control.Arrow
12import Control.Arrow
13import Control.Monad
13import Control.Monad
14import Data.Foldable
14import Data.Foldable
15−import Data.List (sortBy)
15+import Data.List (sortOn)
16−import Data.Ord (comparing)
17import GHC
16import GHC
18import Ormolu.Printer.Combinators
17import Ormolu.Printer.Combinators
19import Ormolu.Printer.Meat.Common
18import Ormolu.Printer.Meat.Common
20import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
19import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
21import Ormolu.Printer.Meat.Type
20import Ormolu.Printer.Meat.Type
22−import Ormolu.Utils
23−import RdrName (RdrName (..))
24
21
25p_classDecl ::
22p_classDecl ::
26 LHsContext GhcPs ->
23 LHsContext GhcPs ->
@@ -31,49 +28,47 @@ p_classDecl ::
31 [LSig GhcPs] ->
28 [LSig GhcPs] ->
32 LHsBinds GhcPs ->
29 LHsBinds GhcPs ->
33 [LFamilyDecl GhcPs] ->
30 [LFamilyDecl GhcPs] ->
34− [LTyFamDefltEqn GhcPs] ->
31+ [LTyFamDefltDecl GhcPs] ->
35 [LDocDecl] ->
32 [LDocDecl] ->
36 R ()
33 R ()
37−p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
34+p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do
38− let HsQTvs {..} = tvars
39− variableSpans = getLoc <$> hsq_explicit
35+ let variableSpans = getLoc <$> hsq_explicit
40 signatureSpans = getLoc name : variableSpans
36 signatureSpans = getLoc name : variableSpans
41 dependencySpans = getLoc <$> fdeps
37 dependencySpans = getLoc <$> fdeps
42 combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)
38 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)
43 txt "class"
53 txt "class"
44 switchLayout combinedSpans $ do
54 switchLayout combinedSpans $ do
45 breakpoint
55 breakpoint
46 inci $ do
56 inci $ do
47 p_classContext ctx
57 p_classContext ctx
48− switchLayout signatureSpans $ do
58+ switchLayout signatureSpans $
49 p_infixDefHelper
59 p_infixDefHelper
50 (isInfix fixity)
60 (isInfix fixity)
51− inci
61+ True
52 (p_rdrName name)
62 (p_rdrName name)
53 (located' p_hsTyVarBndr <$> hsq_explicit)
63 (located' p_hsTyVarBndr <$> hsq_explicit)
54 inci (p_classFundeps fdeps)
64 inci (p_classFundeps fdeps)
55− -- NOTE GHC's AST does not necessarily store each kind of element in
56− -- source location order. This happens because different declarations are
57− -- stored in different lists. Consequently, to get all the declarations in
58− -- proper order, they need to be manually sorted.
59− let sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs
60− vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs
61− tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats
62− docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
63− tyFamDefs =
64− ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
65− )
66− <$> catdefs
67− allDecls =
65+ unless (null allDecls) $ do
68− snd <$> sortBy (comparing fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs)
66+ breakpoint
67+ txt "where"
69 unless (null allDecls) $ do
68 unless (null allDecls) $ do
70− space
71− txt "where"
72 breakpoint -- Ensure whitespace is added after where clause.
69 breakpoint -- Ensure whitespace is added after where clause.
73− -- Add newline before first declaration if the body contains separate
74− -- declarations.
75− when (hasSeparatedDecls allDecls) breakpoint'
76− inci (p_hsDecls Associated allDecls)
70+ inci (p_hsDeclsRespectGrouping Associated allDecls)
71+p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c
77
72
78p_classContext :: LHsContext GhcPs -> R ()
73p_classContext :: LHsContext GhcPs -> R ()
79p_classContext ctx = unless (null (unLoc ctx)) $ do
74p_classContext ctx = unless (null (unLoc ctx)) $ do
@@ -87,7 +82,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do
87 breakpoint
82 breakpoint
88 txt "|"
83 txt "|"
89 space
84 space
90− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps
85+ inci $ sep commaDel (sitcc . located' p_funDep) fdeps
91
86
92p_funDep :: FunDep (Located RdrName) -> R ()
87p_funDep :: FunDep (Located RdrName) -> R ()
93p_funDep (before, after) = do
88p_funDep (before, after) = do
@@ -100,13 +95,6 @@ p_funDep (before, after) = do
100----------------------------------------------------------------------------
95----------------------------------------------------------------------------
101-- Helpers
96-- Helpers
102
97
103−defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
104−defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}
105− where
106− eqn = FamEqn {feqn_pats = tyVarsToTypes feqn_pats, ..}
107− tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}
108−defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"
109−
110isInfix :: LexicalFixity -> Bool
98isInfix :: LexicalFixity -> Bool
111isInfix = \case
99isInfix = \case
112 Infix -> True
100 Infix -> True
src/Ormolu/Printer/Meat/Declaration/Data.hs+74−58
@@ -9,15 +9,12 @@ module Ormolu.Printer.Meat.Declaration.Data
9where
9where
10
10
11import Control.Monad
11import Control.Monad
12−import Data.Maybe (isJust)
12+import Data.Maybe (isJust, maybeToList)
13−import Data.Maybe (maybeToList)
14import GHC
13import GHC
15import Ormolu.Printer.Combinators
14import Ormolu.Printer.Combinators
16import Ormolu.Printer.Meat.Common
15import Ormolu.Printer.Meat.Common
17import Ormolu.Printer.Meat.Type
16import Ormolu.Printer.Meat.Type
18import Ormolu.Utils
17import Ormolu.Utils
19−import RdrName (RdrName (..))
20−import SrcLoc (Located)
21
18
22p_dataDecl ::
19p_dataDecl ::
23 -- | Whether to format as data family
20 -- | Whether to format as data family
@@ -38,12 +35,13 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
38 txt $ case style of
35 txt $ case style of
39 Associated -> mempty
36 Associated -> mempty
40 Free -> " instance"
37 Free -> " instance"
41− switchLayout (getLoc name : fmap getLoc tpats) $ do
38+ let constructorSpans = getLoc name : fmap getLoc tpats
39+ switchLayout constructorSpans $ do
42 breakpoint
40 breakpoint
43 inci $
41 inci $
44 p_infixDefHelper
42 p_infixDefHelper
45 (isInfix fixity)
43 (isInfix fixity)
46− inci
44+ True
47 (p_rdrName name)
45 (p_rdrName name)
48 (located' p_hsType <$> tpats)
46 (located' p_hsType <$> tpats)
49 case dd_kindSig of
47 case dd_kindSig of
@@ -56,29 +54,42 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
56 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons
54 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons
57 unless (null dd_cons) $
55 unless (null dd_cons) $
58 if gadt
56 if gadt
59− then do
57+ then inci $ do
60− space
58+ switchLayout constructorSpans $ do
61− txt "where"
62− breakpoint
63− inci $ sepSemi (located' p_conDecl) dd_cons
64− else switchLayout (getLoc name : (getLoc <$> dd_cons))
65− $ inci
66− $ do
67 breakpoint
59 breakpoint
68− txt "="
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
69− space
66+ then space
67+ else
68+ if hasHaddocks dd_cons
69+ then newline
70+ else breakpoint
71+ equals
72+ space
73+ layout <- getLayout
70− let s =
74+ let s =
71− vlayout
75+ if layout == MultiLine || hasHaddocks dd_cons
72− (space >> txt "|" >> space)
76+ then newline >> txt "|" >> space
73− (newline >> txt "|" >> space)
77+ else space >> txt "|" >> space
78+ sitcc' =
79+ if singleConstRec
80+ then id
81+ else sitcc
74− sep s (sitcc . located' p_conDecl) dd_cons
82+ sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
75 unless (null $ unLoc dd_derivs) breakpoint
83 unless (null $ unLoc dd_derivs) breakpoint
76− inci . located dd_derivs $ \xs -> do
84+ inci . located dd_derivs $ \xs ->
77 sep newline (located' p_hsDerivingClause) xs
85 sep newline (located' p_hsDerivingClause) xs
78−p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"
86+p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x
79
87
88+p_conDecl ::
89+ Bool ->
80−p_conDecl :: ConDecl GhcPs -> R ()
90+ ConDecl GhcPs ->
91+ R ()
81−p_conDecl = \case
92+p_conDecl singleConstRec = \case
82 ConDeclGADT {..} -> do
93 ConDeclGADT {..} -> do
83 mapM_ (p_hsDocString Pipe True) con_doc
94 mapM_ (p_hsDocString Pipe True) con_doc
84 let conDeclSpn =
95 let conDeclSpn =
@@ -93,19 +104,19 @@ p_conDecl = \case
93 (c : cs) -> do
104 (c : cs) -> do
94 p_rdrName c
105 p_rdrName c
95 unless (null cs) . inci $ do
106 unless (null cs) . inci $ do
96− comma
107+ commaDel
97− breakpoint
98− sitcc $ sep (comma >> breakpoint) p_rdrName cs
108+ sep commaDel p_rdrName cs
99− space
100 inci $ do
109 inci $ do
110+ space
101 txt "::"
111 txt "::"
102 let interArgBreak =
112 let interArgBreak =
103 if hasDocStrings (unLoc con_res_ty)
113 if hasDocStrings (unLoc con_res_ty)
104 then newline
114 then newline
105 else breakpoint
115 else breakpoint
106 interArgBreak
116 interArgBreak
107− p_forallBndrs (hsq_explicit con_qvars)
117+ when (unLoc con_forall) $ do
118+ p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)
108− unless (null $ hsq_explicit con_qvars) interArgBreak
119+ interArgBreak
109 forM_ con_mb_cxt p_lhsContext
120 forM_ con_mb_cxt p_lhsContext
110 case con_args of
121 case con_args of
111 PrefixCon xs -> do
122 PrefixCon xs -> do
@@ -124,24 +135,27 @@ p_conDecl = \case
124 p_hsType (unLoc con_res_ty)
135 p_hsType (unLoc con_res_ty)
125 ConDeclH98 {..} -> do
136 ConDeclH98 {..} -> do
126 mapM_ (p_hsDocString Pipe True) con_doc
137 mapM_ (p_hsDocString Pipe True) con_doc
127− let conDeclSpn =
138+ let conDeclWithContextSpn =
128− [getLoc con_name]
139+ [getLoc con_forall]
129 <> fmap getLoc con_ex_tvs
140 <> fmap getLoc con_ex_tvs
130 <> maybeToList (fmap getLoc con_mb_cxt)
141 <> maybeToList (fmap getLoc con_mb_cxt)
142+ <> conDeclSpn
143+ conDeclSpn =
131− <> conArgsSpans con_args
144+ getLoc con_name : conArgsSpans con_args
132− switchLayout conDeclSpn $ do
145+ switchLayout conDeclWithContextSpn $ do
133− p_forallBndrs con_ex_tvs
146+ when (unLoc con_forall) $ do
147+ p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs
134− unless (null con_ex_tvs) breakpoint
148+ breakpoint
135 forM_ con_mb_cxt p_lhsContext
149 forM_ con_mb_cxt p_lhsContext
136− case con_args of
150+ switchLayout conDeclSpn $ case con_args of
137 PrefixCon xs -> do
151 PrefixCon xs -> do
138 p_rdrName con_name
152 p_rdrName con_name
139 unless (null xs) breakpoint
153 unless (null xs) breakpoint
140− inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs
154+ inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs
141 RecCon l -> do
155 RecCon l -> do
142 p_rdrName con_name
156 p_rdrName con_name
143 breakpoint
157 breakpoint
144− inci $ located l p_conDeclFields
158+ inciIf (not singleConstRec) (located l p_conDeclFields)
145 InfixCon x y -> do
159 InfixCon x y -> do
146 located x p_hsType
160 located x p_hsType
147 breakpoint
161 breakpoint
@@ -149,7 +163,7 @@ p_conDecl = \case
149 p_rdrName con_name
163 p_rdrName con_name
150 space
164 space
151 located y p_hsType
165 located y p_hsType
152− XConDecl NoExt -> notImplemented "XConDecl"
166+ XConDecl x -> noExtCon x
153
167
154conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
168conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
155conArgsSpans = \case
169conArgsSpans = \case
@@ -163,18 +177,7 @@ conArgsSpans = \case
163conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
177conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
164conTyVarsSpans = \case
178conTyVarsSpans = \case
165 HsQTvs {..} -> getLoc <$> hsq_explicit
179 HsQTvs {..} -> getLoc <$> hsq_explicit
166− XLHsQTyVars NoExt -> []
180+ XLHsQTyVars x -> noExtCon x
167−
168−p_forallBndrs ::
169− [LHsTyVarBndr GhcPs] ->
170− R ()
171−p_forallBndrs = \case
172− [] -> return ()
173− bndrs -> do
174− txt "forall"
175− space
176− sep space (located' p_hsTyVarBndr) bndrs
177− txt "."
178
181
179p_lhsContext ::
182p_lhsContext ::
180 LHsContext GhcPs ->
183 LHsContext GhcPs ->
@@ -201,9 +204,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
201 let derivingWhat = located deriv_clause_tys $ \case
204 let derivingWhat = located deriv_clause_tys $ \case
202 [] -> txt "()"
205 [] -> txt "()"
203 xs ->
206 xs ->
204− parens N . sitcc $
207+ parens N $
205 sep
208 sep
206− (comma >> breakpoint)
209+ commaDel
207 (sitcc . located' p_hsType . hsib_body)
210 (sitcc . located' p_hsType . hsib_body)
208 xs
211 xs
209 space
212 space
@@ -232,9 +235,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
232 txt "via"
235 txt "via"
233 space
236 space
234 located hsib_body p_hsType
237 located hsib_body p_hsType
235− ViaStrategy (XHsImplicitBndrs NoExt) ->
238+ ViaStrategy (XHsImplicitBndrs x) ->
236− notImplemented "XHsImplicitBndrs"
239+ noExtCon x
237−p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
240+p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
238
241
239----------------------------------------------------------------------------
242----------------------------------------------------------------------------
240-- Helpers
243-- Helpers
@@ -243,3 +246,16 @@ isInfix :: LexicalFixity -> Bool
243isInfix = \case
246isInfix = \case
244 Infix -> True
247 Infix -> True
245 Prefix -> False
248 Prefix -> False
249+
250+isSingleConstRec :: [LConDecl GhcPs] -> Bool
251+isSingleConstRec [(L _ ConDeclH98 {..})] =
252+ case con_args of
253+ RecCon _ -> True
254+ _ -> False
255+isSingleConstRec _ = False
256+
257+hasHaddocks :: [LConDecl GhcPs] -> Bool
258+hasHaddocks = any (f . unLoc)
259+ where
260+ f ConDeclH98 {..} = isJust con_doc
261+ f _ = False
src/Ormolu/Printer/Meat/Declaration/Default.hs+4−5
@@ -9,13 +9,12 @@ where
9import GHC
9import GHC
10import Ormolu.Printer.Combinators
10import Ormolu.Printer.Combinators
11import Ormolu.Printer.Meat.Type
11import Ormolu.Printer.Meat.Type
12−import Ormolu.Utils
13
12
14p_defaultDecl :: DefaultDecl GhcPs -> R ()
13p_defaultDecl :: DefaultDecl GhcPs -> R ()
15p_defaultDecl = \case
14p_defaultDecl = \case
16− DefaultDecl NoExt ts -> do
15+ DefaultDecl NoExtField ts -> do
17 txt "default"
16 txt "default"
18 breakpoint
17 breakpoint
19− inci . parens N . sitcc $
18+ inci . parens N $
20− sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
19+ sep commaDel (sitcc . located' p_hsType) ts
21− XDefaultDecl {} -> notImplemented "XDefaultDecl"
20+ XDefaultDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Foreign.hs+9−7
@@ -15,7 +15,6 @@ import GHC
15import Ormolu.Printer.Combinators
15import Ormolu.Printer.Combinators
16import Ormolu.Printer.Meat.Common
16import Ormolu.Printer.Meat.Common
17import Ormolu.Printer.Meat.Declaration.Signature
17import Ormolu.Printer.Meat.Declaration.Signature
18−import Ormolu.Utils
19
18
20p_foreignDecl :: ForeignDecl GhcPs -> R ()
19p_foreignDecl :: ForeignDecl GhcPs -> R ()
21p_foreignDecl = \case
20p_foreignDecl = \case
@@ -25,18 +24,21 @@ p_foreignDecl = \case
25 fd@ForeignExport {fd_fe} -> do
24 fd@ForeignExport {fd_fe} -> do
26 p_foreignExport fd_fe
25 p_foreignExport fd_fe
27 p_foreignTypeSig fd
26 p_foreignTypeSig fd
28− XForeignDecl {} -> notImplemented "XForeignDecl"
27+ XForeignDecl x -> noExtCon x
29
28
30-- | Printer for the last part of an import\/export, which is function name
29-- | Printer for the last part of an import\/export, which is function name
31-- and type signature.
30-- and type signature.
32p_foreignTypeSig :: ForeignDecl GhcPs -> R ()
31p_foreignTypeSig :: ForeignDecl GhcPs -> R ()
33p_foreignTypeSig fd = do
32p_foreignTypeSig fd = do
34 breakpoint
33 breakpoint
35− -- Switch into the layout of the signature, to allow us to pull name and
34+ inci
36− -- signature onto a single line.
35+ . switchLayout
36+ [ getLoc (fd_name fd),
37− inci . switchLayout [getLoc . hsib_body $ fd_sig_ty fd] $ do
37+ (getLoc . hsib_body . fd_sig_ty) fd
38+ ]
39+ $ do
38− p_rdrName (fd_name fd)
40+ p_rdrName (fd_name fd)
39− p_typeAscription (HsWC NoExt (fd_sig_ty fd))
41+ p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
40
42
41-- | Printer for 'ForeignImport'.
43-- | Printer for 'ForeignImport'.
42--
44--
src/Ormolu/Printer/Meat/Declaration/Instance.hs+22−28
@@ -15,8 +15,7 @@ import BasicTypes
15import Control.Arrow
15import Control.Arrow
16import Control.Monad
16import Control.Monad
17import Data.Foldable
17import Data.Foldable
18−import Data.List (sortBy)
18+import Data.List (sortOn)
19−import Data.Ord (comparing)
20import GHC
19import GHC
21import Ormolu.Printer.Combinators
20import Ormolu.Printer.Combinators
22import Ormolu.Printer.Meat.Common
21import Ormolu.Printer.Meat.Common
@@ -33,13 +32,11 @@ p_standaloneDerivDecl DerivDecl {..} = do
33 txt "instance"
32 txt "instance"
34 breakpoint
33 breakpoint
35 match_overlap_mode deriv_overlap_mode breakpoint
34 match_overlap_mode deriv_overlap_mode breakpoint
36− if toIndent
37− then inci typesAfterInstance
38− else typesAfterInstance
35+ inciIf toIndent typesAfterInstance
39 txt "deriving"
36 txt "deriving"
40 space
37 space
41 case deriv_strategy of
38 case deriv_strategy of
42− Nothing -> do
39+ Nothing ->
43 instTypes False
40 instTypes False
44 Just (L _ a) -> case a of
41 Just (L _ a) -> case a of
45 StockStrategy -> do
42 StockStrategy -> do
@@ -57,8 +54,8 @@ p_standaloneDerivDecl DerivDecl {..} = do
57 inci (located hsib_body p_hsType)
54 inci (located hsib_body p_hsType)
58 breakpoint
55 breakpoint
59 instTypes True
56 instTypes True
60− ViaStrategy (XHsImplicitBndrs NoExt) ->
57+ ViaStrategy (XHsImplicitBndrs x) ->
61− notImplemented "XHsImplicitBndrs"
58+ noExtCon x
62p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
59p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
63
60
64p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
61p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
@@ -71,19 +68,18 @@ p_clsInstDecl = \case
71 -- location order. This happens because different declarations are stored in
68 -- location order. This happens because different declarations are stored in
72 -- different lists. Consequently, to get all the declarations in proper
69 -- different lists. Consequently, to get all the declarations in proper
73 -- order, they need to be manually sorted.
70 -- order, they need to be manually sorted.
74− let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs
71+ let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs
75− vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
72+ vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds
76 tyFamInsts =
73 tyFamInsts =
77− ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
74+ ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
78 )
75 )
79 <$> cid_tyfam_insts
76 <$> cid_tyfam_insts
80 dataFamInsts =
77 dataFamInsts =
81− ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
78+ ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)
82 )
79 )
83 <$> cid_datafam_insts
80 <$> cid_datafam_insts
84 allDecls =
81 allDecls =
85− snd
86− <$> sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
82+ snd <$> sortOn fst (sigs <> vals <> tyFamInsts <> dataFamInsts)
87 located hsib_body $ \x -> do
83 located hsib_body $ \x -> do
88 breakpoint
84 breakpoint
89 inci $ do
85 inci $ do
@@ -92,16 +88,12 @@ p_clsInstDecl = \case
92 unless (null allDecls) $ do
88 unless (null allDecls) $ do
93 breakpoint
89 breakpoint
94 txt "where"
90 txt "where"
95− unless (null allDecls) $ do
91+ unless (null allDecls) . inci $ do
96− inci $ do
97− -- Ensure whitespace is added after where clause.
92+ -- Ensure whitespace is added after where clause.
98− breakpoint
93+ breakpoint
99− -- Add newline before first declaration if the body contains separate
100− -- declarations
101− when (hasSeparatedDecls allDecls) breakpoint'
102− dontUseBraces $ p_hsDecls Associated allDecls
94+ dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
103− XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"
95+ XHsImplicitBndrs x -> noExtCon x
104− XClsInstDecl NoExt -> notImplemented "XClsInstDecl"
96+ XClsInstDecl x -> noExtCon x
105
97
106p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
98p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
107p_tyFamInstDecl style = \case
99p_tyFamInstDecl style = \case
@@ -114,10 +106,12 @@ p_tyFamInstDecl style = \case
114
106
115p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()
107p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()
116p_dataFamInstDecl style = \case
108p_dataFamInstDecl style = \case
117− DataFamInstDecl {..} -> do
109+ DataFamInstDecl {dfid_eqn = HsIB {hsib_body = FamEqn {..}}} ->
118− let HsIB {..} = dfid_eqn
119− FamEqn {..} = hsib_body
120− p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs
110+ p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs
111+ DataFamInstDecl {dfid_eqn = HsIB {hsib_body = XFamEqn {}}} ->
112+ notImplemented "XFamEqn"
113+ DataFamInstDecl {dfid_eqn = XHsImplicitBndrs {}} ->
114+ notImplemented "XHsImplicitBndrs"
121
115
122match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
116match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
123match_overlap_mode overlap_mode layoutStrategy =
117match_overlap_mode overlap_mode layoutStrategy =
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+2−6
@@ -1,6 +1,5 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
5
4
6-- | Rendering of Role annotation declarations.
5-- | Rendering of Role annotation declarations.
@@ -13,14 +12,11 @@ import CoAxiom
13import GHC
12import GHC
14import Ormolu.Printer.Combinators
13import Ormolu.Printer.Combinators
15import Ormolu.Printer.Meat.Common
14import Ormolu.Printer.Meat.Common
16−import Ormolu.Utils
17−import RdrName (RdrName (..))
18−import SrcLoc (Located)
19
15
20p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
16p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
21p_roleAnnot = \case
17p_roleAnnot = \case
22− RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns
18+ RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns
23− XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"
19+ XRoleAnnotDecl x -> noExtCon x
24
20
25p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
21p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
26p_roleAnnot' l_name anns = do
22p_roleAnnot' l_name anns = do
src/Ormolu/Printer/Meat/Declaration/Rule.hs+22−23
@@ -1,6 +1,5 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4
3
5module Ormolu.Printer.Meat.Declaration.Rule
4module Ormolu.Printer.Meat.Declaration.Rule
6 ( p_ruleDecls,
5 ( p_ruleDecls,
@@ -8,55 +7,55 @@ module Ormolu.Printer.Meat.Declaration.Rule
8where
7where
9
8
10import BasicTypes
9import BasicTypes
10+import Control.Monad (unless)
11import GHC
11import GHC
12import Ormolu.Printer.Combinators
12import Ormolu.Printer.Combinators
13import Ormolu.Printer.Meat.Common
13import Ormolu.Printer.Meat.Common
14import Ormolu.Printer.Meat.Declaration.Signature
14import Ormolu.Printer.Meat.Declaration.Signature
15import Ormolu.Printer.Meat.Declaration.Value
15import Ormolu.Printer.Meat.Declaration.Value
16−import Ormolu.Utils
16+import Ormolu.Printer.Meat.Type
17
17
18p_ruleDecls :: RuleDecls GhcPs -> R ()
18p_ruleDecls :: RuleDecls GhcPs -> R ()
19p_ruleDecls = \case
19p_ruleDecls = \case
20− HsRules NoExt _ xs ->
20+ HsRules NoExtField _ xs ->
21− pragma "RULES" . sitcc $
21+ pragma "RULES" $
22 sep breakpoint (sitcc . located' p_ruleDecl) xs
22 sep breakpoint (sitcc . located' p_ruleDecl) xs
23− XRuleDecls NoExt -> notImplemented "XRuleDecls"
23+ XRuleDecls x -> noExtCon x
24
24
25p_ruleDecl :: RuleDecl GhcPs -> R ()
25p_ruleDecl :: RuleDecl GhcPs -> R ()
26p_ruleDecl = \case
26p_ruleDecl = \case
27− HsRule NoExt ruleName activation ruleBndrs lhs rhs -> do
27+ HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do
28 located ruleName p_ruleName
28 located ruleName p_ruleName
29 space
29 space
30 p_activation activation
30 p_activation activation
31 space
31 space
32− p_ruleBndrs ruleBndrs
32+ case tyvars of
33+ Nothing -> return ()
34+ Just xs -> do
35+ p_forallBndrs ForallInvis p_hsTyVarBndr xs
36+ space
37+ -- 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+ -- foralls, so let's just skip the empty ones.
40+ unless (null ruleBndrs) $
41+ p_forallBndrs ForallInvis p_ruleBndr ruleBndrs
33 breakpoint
42 breakpoint
34 inci $ do
43 inci $ do
35 located lhs p_hsExpr
44 located lhs p_hsExpr
36 space
45 space
37− txt "="
46+ equals
38 inci $ do
47 inci $ do
39 breakpoint
48 breakpoint
40 located rhs p_hsExpr
49 located rhs p_hsExpr
41− XRuleDecl NoExt -> notImplemented "XRuleDecl"
50+ XRuleDecl x -> noExtCon x
42
51
43p_ruleName :: (SourceText, RuleName) -> R ()
52p_ruleName :: (SourceText, RuleName) -> R ()
44−p_ruleName (_, name) = atom $ HsString NoSourceText name
53+p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)
45−
46−p_ruleBndrs :: [LRuleBndr GhcPs] -> R ()
47−p_ruleBndrs [] = return ()
48−p_ruleBndrs bndrs =
49− switchLayout (getLoc <$> bndrs) $ do
50− txt "forall"
51− breakpoint
52− inci $ do
53− sitcc $ sep breakpoint (sitcc . located' p_ruleBndr) bndrs
54− txt "."
55
54
56p_ruleBndr :: RuleBndr GhcPs -> R ()
55p_ruleBndr :: RuleBndr GhcPs -> R ()
57p_ruleBndr = \case
56p_ruleBndr = \case
58− RuleBndr NoExt x -> p_rdrName x
57+ RuleBndr NoExtField x -> p_rdrName x
59− RuleBndrSig NoExt x hswc -> parens N $ do
58+ RuleBndrSig NoExtField x hswc -> parens N $ do
60 p_rdrName x
59 p_rdrName x
61 p_typeAscription hswc
60 p_typeAscription hswc
62− XRuleBndr NoExt -> notImplemented "XRuleBndr"
61+ XRuleBndr x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Signature.hs+49−33
@@ -7,13 +7,13 @@ module Ormolu.Printer.Meat.Declaration.Signature
7 ( p_sigDecl,
7 ( p_sigDecl,
8 p_typeAscription,
8 p_typeAscription,
9 p_activation,
9 p_activation,
10+ p_standaloneKindSig,
10 )
11 )
11where
12where
12
13
13import BasicTypes
14import BasicTypes
14import BooleanFormula
15import BooleanFormula
15import Control.Monad
16import Control.Monad
16−import Data.Bool (bool)
17import GHC
17import GHC
18import Ormolu.Printer.Combinators
18import Ormolu.Printer.Combinators
19import Ormolu.Printer.Meat.Common
19import Ormolu.Printer.Meat.Common
@@ -22,16 +22,16 @@ import Ormolu.Utils
22
22
23p_sigDecl :: Sig GhcPs -> R ()
23p_sigDecl :: Sig GhcPs -> R ()
24p_sigDecl = \case
24p_sigDecl = \case
25− TypeSig NoExt names hswc -> p_typeSig True names hswc
25+ TypeSig NoExtField names hswc -> p_typeSig True names hswc
26− PatSynSig NoExt names hsib -> p_patSynSig names hsib
26+ PatSynSig NoExtField names hsib -> p_patSynSig names hsib
27− ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib
27+ ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib
28− FixSig NoExt sig -> p_fixSig sig
28+ FixSig NoExtField sig -> p_fixSig sig
29− InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma
29+ InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma
30− SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma
30+ SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma
31− SpecInstSig NoExt _ hsib -> p_specInstSig hsib
31+ SpecInstSig NoExtField _ hsib -> p_specInstSig hsib
32− MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula
32+ MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula
33− CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty
33+ CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty
34− SCCFunSig NoExt _ name literal -> p_sccSig name literal
34+ SCCFunSig NoExtField _ name literal -> p_sccSig name literal
35 _ -> notImplemented "certain types of signature declarations"
35 _ -> notImplemented "certain types of signature declarations"
36
36
37p_typeSig ::
37p_typeSig ::
@@ -47,25 +47,23 @@ p_typeSig indentTail (n : ns) hswc = do
47 p_rdrName n
47 p_rdrName n
48 if null ns
48 if null ns
49 then p_typeAscription hswc
49 then p_typeAscription hswc
50− else bool id inci indentTail $ do
50+ else inciIf indentTail $ do
51− comma
51+ commaDel
52− breakpoint
53− sep (comma >> breakpoint) p_rdrName ns
52+ sep commaDel p_rdrName ns
54 p_typeAscription hswc
53 p_typeAscription hswc
55
54
56p_typeAscription ::
55p_typeAscription ::
57 LHsSigWcType GhcPs ->
56 LHsSigWcType GhcPs ->
58 R ()
57 R ()
59−p_typeAscription HsWC {..} = do
58+p_typeAscription HsWC {..} = inci $ do
60 space
59 space
61− inci $ do
62− txt "::"
60+ txt "::"
63− let t = hsib_body hswc_body
61+ let t = hsib_body hswc_body
64− if hasDocStrings (unLoc t)
62+ if hasDocStrings (unLoc t)
65− then newline
63+ then newline
66− else breakpoint
64+ else breakpoint
67− located t p_hsType
65+ located t p_hsType
68−p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
66+p_typeAscription (XHsWildCardBndrs x) = noExtCon x
69
67
70p_patSynSig ::
68p_patSynSig ::
71 [Located RdrName] ->
69 [Located RdrName] ->
@@ -73,7 +71,11 @@ p_patSynSig ::
73 R ()
71 R ()
74p_patSynSig names hsib = do
72p_patSynSig names hsib = do
75 txt "pattern"
73 txt "pattern"
74+ let body =
75+ p_typeSig
76+ False
77+ names
76− let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
78+ HsWC {hswc_ext = NoExtField, hswc_body = hsib}
77 if length names > 1
79 if length names > 1
78 then breakpoint >> inci body
80 then breakpoint >> inci body
79 else space >> body
81 else space >> body
@@ -88,13 +90,13 @@ p_classOpSig ::
88 R ()
90 R ()
89p_classOpSig def names hsib = do
91p_classOpSig def names hsib = do
90 when def (txt "default" >> space)
92 when def (txt "default" >> space)
91− p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
93+ p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
92
94
93p_fixSig ::
95p_fixSig ::
94 FixitySig GhcPs ->
96 FixitySig GhcPs ->
95 R ()
97 R ()
96p_fixSig = \case
98p_fixSig = \case
97− FixitySig NoExt names (Fixity _ n dir) -> do
99+ FixitySig NoExtField names (Fixity _ n dir) -> do
98 txt $ case dir of
100 txt $ case dir of
99 InfixL -> "infixl"
101 InfixL -> "infixl"
100 InfixR -> "infixr"
102 InfixR -> "infixr"
@@ -102,8 +104,8 @@ p_fixSig = \case
102 space
104 space
103 atom n
105 atom n
104 space
106 space
105− sitcc $ sep (comma >> breakpoint) p_rdrName names
107+ sitcc $ sep commaDel p_rdrName names
106− XFixitySig NoExt -> notImplemented "XFixitySig"
108+ XFixitySig x -> noExtCon x
107
109
108p_inlineSig ::
110p_inlineSig ::
109 -- | Name
111 -- | Name
@@ -141,7 +143,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do
141 space
143 space
142 txt "::"
144 txt "::"
143 breakpoint
145 breakpoint
144− inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts
146+ inci $ sep commaDel (located' p_hsType . hsib_body) ts
145
147
146p_inlineSpec :: InlineSpec -> R ()
148p_inlineSpec :: InlineSpec -> R ()
147p_inlineSpec = \case
149p_inlineSpec = \case
@@ -185,13 +187,13 @@ p_booleanFormula = \case
185 And xs ->
187 And xs ->
186 sitcc $
188 sitcc $
187 sep
189 sep
188− (comma >> breakpoint)
190+ commaDel
189 (located' p_booleanFormula)
191 (located' p_booleanFormula)
190 xs
192 xs
191 Or xs ->
193 Or xs ->
192 sitcc $
194 sitcc $
193 sep
195 sep
194− (breakpoint >> txt "| ")
196+ (breakpoint >> txt "|" >> space)
195 (located' p_booleanFormula)
197 (located' p_booleanFormula)
196 xs
198 xs
197 Parens l -> located l (parens N . p_booleanFormula)
199 Parens l -> located l (parens N . p_booleanFormula)
@@ -205,7 +207,7 @@ p_completeSig ::
205p_completeSig cs' mty =
207p_completeSig cs' mty =
206 located cs' $ \cs ->
208 located cs' $ \cs ->
207 pragma "COMPLETE" . inci $ do
209 pragma "COMPLETE" . inci $ do
208− sitcc $ sep (comma >> breakpoint) p_rdrName cs
210+ sep commaDel p_rdrName cs
209 forM_ mty $ \ty -> do
211 forM_ mty $ \ty -> do
210 space
212 space
211 txt "::"
213 txt "::"
@@ -218,3 +220,17 @@ p_sccSig loc literal = pragma "SCC" . inci $ do
218 forM_ literal $ \x -> do
220 forM_ literal $ \x -> do
219 breakpoint
221 breakpoint
220 atom x
222 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+2−3
@@ -8,9 +8,8 @@ where
8import GHC
8import GHC
9import Ormolu.Printer.Combinators
9import Ormolu.Printer.Combinators
10import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
10import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
11−import Ormolu.Utils
12
11
13p_spliceDecl :: SpliceDecl GhcPs -> R ()
12p_spliceDecl :: SpliceDecl GhcPs -> R ()
14p_spliceDecl = \case
13p_spliceDecl = \case
15− SpliceDecl NoExt splice _explicit -> located splice p_hsSplice
14+ SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice
16− XSpliceDecl {} -> notImplemented "XSpliceDecl"
15+ XSpliceDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Type.hs+8−8
@@ -11,8 +11,6 @@ import GHC
11import Ormolu.Printer.Combinators
11import Ormolu.Printer.Combinators
12import Ormolu.Printer.Meat.Common
12import Ormolu.Printer.Meat.Common
13import Ormolu.Printer.Meat.Type
13import Ormolu.Printer.Meat.Type
14−import RdrName (RdrName (..))
15−import SrcLoc (Located)
16
14
17p_synDecl ::
15p_synDecl ::
18 -- | Type constructor
16 -- | Type constructor
@@ -24,17 +22,19 @@ p_synDecl ::
24 -- | RHS of type declaration
22 -- | RHS of type declaration
25 LHsType GhcPs ->
23 LHsType GhcPs ->
26 R ()
24 R ()
27−p_synDecl name fixity tvars t = do
25+p_synDecl name fixity HsQTvs {..} t = do
28 txt "type"
26 txt "type"
29 space
27 space
30− let HsQTvs {..} = tvars
31− switchLayout (getLoc name : map getLoc hsq_explicit) $ do
28+ switchLayout (getLoc name : map getLoc hsq_explicit) $
32 p_infixDefHelper
29 p_infixDefHelper
33 (case fixity of Infix -> True; _ -> False)
30 (case fixity of Infix -> True; _ -> False)
34− inci
31+ True
35 (p_rdrName name)
32 (p_rdrName name)
36 (map (located' p_hsTyVarBndr) hsq_explicit)
33 (map (located' p_hsTyVarBndr) hsq_explicit)
37 space
34 space
38− txt "="
35+ equals
36+ if hasDocStrings (unLoc t)
37+ then newline
39− breakpoint
38+ else breakpoint
40 inci (located t p_hsType)
39 inci (located t p_hsType)
40+p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+42−37
@@ -9,18 +9,16 @@ module Ormolu.Printer.Meat.Declaration.TypeFamily
9 )
9 )
10where
10where
11
11
12−import BasicTypes (LexicalFixity (..))
13import Control.Monad
12import Control.Monad
14−import Data.Maybe (isJust, isNothing)
13+import Data.Maybe (isNothing)
15import GHC
14import GHC
16import Ormolu.Printer.Combinators
15import Ormolu.Printer.Combinators
17import Ormolu.Printer.Meat.Common
16import Ormolu.Printer.Meat.Common
18import Ormolu.Printer.Meat.Type
17import Ormolu.Printer.Meat.Type
19import Ormolu.Utils
18import Ormolu.Utils
20−import SrcLoc (GenLocated (..), Located)
21
19
22p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
20p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
23−p_famDecl style FamilyDecl {..} = do
21+p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
24 mmeqs <- case fdInfo of
22 mmeqs <- case fdInfo of
25 DataFamily -> Nothing <$ txt "data"
23 DataFamily -> Nothing <$ txt "data"
26 OpenTypeFamily -> Nothing <$ txt "type"
24 OpenTypeFamily -> Nothing <$ txt "type"
@@ -28,27 +26,26 @@ p_famDecl style FamilyDecl {..} = do
28 txt $ case style of
26 txt $ case style of
29 Associated -> mempty
27 Associated -> mempty
30 Free -> " family"
28 Free -> " family"
31− let HsQTvs {..} = fdTyVars
32 breakpoint
29 breakpoint
33 inci $ do
30 inci $ do
34− switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $ do
31+ switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $
35 p_infixDefHelper
32 p_infixDefHelper
36 (isInfix fdFixity)
33 (isInfix fdFixity)
37− inci
34+ True
38 (p_rdrName fdLName)
35 (p_rdrName fdLName)
39 (located' p_hsTyVarBndr <$> hsq_explicit)
36 (located' p_hsTyVarBndr <$> hsq_explicit)
40− let rsig = p_familyResultSigL (isJust fdInjectivityAnn) fdResultSig
37+ let resultSig = p_familyResultSigL fdResultSig
41− unless (isNothing rsig && isNothing fdInjectivityAnn) $
38+ unless (isNothing resultSig && isNothing fdInjectivityAnn) space
42− space
43 inci $ do
39 inci $ do
44− sequence_ rsig
40+ sequence_ resultSig
45− when (isJust rsig && isJust fdInjectivityAnn) breakpoint
41+ space
46 forM_ fdInjectivityAnn (located' p_injectivityAnn)
42 forM_ fdInjectivityAnn (located' p_injectivityAnn)
47 case mmeqs of
43 case mmeqs of
48 Nothing -> return ()
44 Nothing -> return ()
49 Just meqs -> do
45 Just meqs -> do
50− space
46+ inci $ do
47+ breakpoint
51− txt "where"
48+ txt "where"
52 case meqs of
49 case meqs of
53 Nothing -> do
50 Nothing -> do
54 space
51 space
@@ -56,26 +53,27 @@ p_famDecl style FamilyDecl {..} = do
56 Just eqs -> do
53 Just eqs -> do
57 newline
54 newline
58 sep newline (located' (inci . p_tyFamInstEqn)) eqs
55 sep newline (located' (inci . p_tyFamInstEqn)) eqs
59−p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
56+p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
57+ notImplemented "XLHsQTyVars"
58+p_famDecl _ (XFamilyDecl x) = noExtCon x
60
59
61p_familyResultSigL ::
60p_familyResultSigL ::
62− Bool ->
63 Located (FamilyResultSig GhcPs) ->
61 Located (FamilyResultSig GhcPs) ->
64 Maybe (R ())
62 Maybe (R ())
65−p_familyResultSigL injAnn l =
63+p_familyResultSigL l =
66 case l of
64 case l of
67 L _ a -> case a of
65 L _ a -> case a of
68− NoSig NoExt -> Nothing
66+ NoSig NoExtField -> Nothing
69− KindSig NoExt k -> Just $ do
67+ KindSig NoExtField k -> Just $ do
70− if injAnn then txt "=" else txt "::"
68+ txt "::"
71 breakpoint
69 breakpoint
72 located k p_hsType
70 located k p_hsType
73− TyVarSig NoExt bndr -> Just $ do
71+ TyVarSig NoExtField bndr -> Just $ do
74− if injAnn then txt "=" else txt "::"
72+ equals
75 breakpoint
73 breakpoint
76 located bndr p_hsTyVarBndr
74 located bndr p_hsTyVarBndr
77− XFamilyResultSig NoExt ->
75+ XFamilyResultSig x ->
78− notImplemented "XFamilyResultSig"
76+ noExtCon x
79
77
80p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
78p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
81p_injectivityAnn (InjectivityAnn a bs) = do
79p_injectivityAnn (InjectivityAnn a bs) = do
@@ -88,19 +86,26 @@ p_injectivityAnn (InjectivityAnn a bs) = do
88 sep space p_rdrName bs
86 sep space p_rdrName bs
89
87
90p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
88p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
91−p_tyFamInstEqn HsIB {..} = do
89+p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
92− let FamEqn {..} = hsib_body
90+ case feqn_bndrs of
91+ Nothing -> return ()
92+ Just bndrs -> do
93+ p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
94+ breakpoint
95+ inciIf (not $ null feqn_bndrs) $ do
93− switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $
96+ let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
97+ switchLayout famLhsSpn $
94− p_infixDefHelper
98+ p_infixDefHelper
95− (isInfix feqn_fixity)
99+ (isInfix feqn_fixity)
96− inci
100+ True
97− (p_rdrName feqn_tycon)
101+ (p_rdrName feqn_tycon)
98− (located' p_hsType <$> feqn_pats)
102+ (located' p_hsType . typeArgToType <$> feqn_pats)
99− space
103+ space
100− txt "="
104+ equals
101− breakpoint
105+ breakpoint
102− inci (located feqn_rhs p_hsType)
106+ inci (located feqn_rhs p_hsType)
103−p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
107+p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
108+p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
104
109
105----------------------------------------------------------------------------
110----------------------------------------------------------------------------
106-- Helpers
111-- Helpers
src/Ormolu/Printer/Meat/Declaration/Value.hs+452−342
@@ -1,6 +1,8 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE TypeApplications #-}
4
6
5module Ormolu.Printer.Meat.Declaration.Value
7module Ormolu.Printer.Meat.Declaration.Value
6 ( p_valDecl,
8 ( p_valDecl,
@@ -18,23 +20,22 @@ import Ctype (is_space)
18import Data.Bool (bool)
20import Data.Bool (bool)
19import Data.Char (isPunctuation, isSymbol)
21import Data.Char (isPunctuation, isSymbol)
20import Data.Data hiding (Infix, Prefix)
22import Data.Data hiding (Infix, Prefix)
23+import Data.Functor ((<&>))
21import Data.List (intersperse, sortOn)
24import Data.List (intersperse, sortOn)
22−import Data.List.NonEmpty (NonEmpty ((:|)))
25+import Data.List.NonEmpty (NonEmpty (..), (<|))
23import qualified Data.List.NonEmpty as NE
26import qualified Data.List.NonEmpty as NE
24import Data.Text (Text)
27import Data.Text (Text)
25import qualified Data.Text as Text
28import qualified Data.Text as Text
26import GHC
29import GHC
27−import OccName (mkVarOcc)
30+import OccName (occNameString)
28import Ormolu.Printer.Combinators
31import Ormolu.Printer.Combinators
32+import Ormolu.Printer.Internal
29import Ormolu.Printer.Meat.Common
33import Ormolu.Printer.Meat.Common
30import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
34import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
31import Ormolu.Printer.Meat.Declaration.Signature
35import Ormolu.Printer.Meat.Declaration.Signature
32import Ormolu.Printer.Meat.Type
36import Ormolu.Printer.Meat.Type
33import Ormolu.Printer.Operators
37import Ormolu.Printer.Operators
34import Ormolu.Utils
38import Ormolu.Utils
35−import RdrName (RdrName (..))
36−import RdrName (rdrNameOcc)
37−import SrcLoc (combineSrcSpans, isOneLineSpan)
38
39
39-- | Style of a group of equations.
40-- | Style of a group of equations.
40data MatchGroupStyle
41data MatchGroupStyle
@@ -60,16 +61,16 @@ data Placement
60 -- should use it and avoid bumping one level
61 -- should use it and avoid bumping one level
61 -- of indentation
62 -- of indentation
62 Hanging
63 Hanging
63− deriving (Eq)
64+ deriving (Eq, Show)
64
65
65p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
66p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
66p_valDecl = \case
67p_valDecl = \case
67− FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
68+ FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
68− PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
69+ PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
69 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
70 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
70 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
71 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
71− PatSynBind NoExt psb -> p_patSynBind psb
72+ PatSynBind NoExtField psb -> p_patSynBind psb
72− XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
73+ XHsBindsLR x -> noExtCon x
73
74
74p_funBind ::
75p_funBind ::
75 Located RdrName ->
76 Located RdrName ->
@@ -99,7 +100,7 @@ p_matchGroup' placer render style MG {..} = do
99 Case -> id
100 Case -> id
100 LambdaCase -> id
101 LambdaCase -> id
101 _ -> dontUseBraces
102 _ -> dontUseBraces
102− -- NOTE since we are forcing braces on 'sepSemi' based on 'ob', we have to
103+ -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to
103 -- restore the brace state inside the sepsemi.
104 -- restore the brace state inside the sepsemi.
104 ub <- bool dontUseBraces useBraces <$> canUseBraces
105 ub <- bool dontUseBraces useBraces <$> canUseBraces
105 ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts)
106 ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts)
@@ -113,8 +114,8 @@ p_matchGroup' placer render style MG {..} = do
113 (matchStrictness m)
114 (matchStrictness m)
114 m_pats
115 m_pats
115 m_grhss
116 m_grhss
116− p_Match _ = notImplemented "XMatch"
117+ p_Match (XMatch x) = noExtCon x
117−p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
118+p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
118
119
119-- | Function id obtained through pattern matching on 'FunBind' should not
120-- | Function id obtained through pattern matching on 'FunBind' should not
120-- be used to print the actual equations because the different ‘RdrNames’
121-- be used to print the actual equations because the different ‘RdrNames’
@@ -167,9 +168,9 @@ p_match' ::
167 -- | Equations
168 -- | Equations
168 GRHSs GhcPs (Located body) ->
169 GRHSs GhcPs (Located body) ->
169 R ()
170 R ()
170−p_match' placer render style isInfix strictness m_pats m_grhss = do
171+p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
171− -- NOTE Normally, since patterns may be placed in a multi-line layout, it
172+ -- Normally, since patterns may be placed in a multi-line layout, it is
172− -- is necessary to bump indentation for the pattern group so it's more
173+ -- necessary to bump indentation for the pattern group so it's more
173 -- indented than function name. This in turn means that indentation for
174 -- indented than function name. This in turn means that indentation for
174 -- the body should also be bumped. Normally this would mean that bodies
175 -- the body should also be bumped. Normally this would mean that bodies
175 -- would start with two indentation steps applied, which is ugly, so we
176 -- would start with two indentation steps applied, which is ugly, so we
@@ -179,25 +180,24 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
179 NoSrcStrict -> return ()
180 NoSrcStrict -> return ()
180 SrcStrict -> txt "!"
181 SrcStrict -> txt "!"
181 SrcLazy -> txt "~"
182 SrcLazy -> txt "~"
182− inci' <- case NE.nonEmpty m_pats of
183+ indentBody <- case NE.nonEmpty m_pats of
184+ Nothing ->
183− Nothing -> id <$ case style of
185+ False <$ case style of
184− Function name -> p_rdrName name
186+ Function name -> p_rdrName name
185− _ -> return ()
187+ _ -> return ()
186 Just ne_pats -> do
188 Just ne_pats -> do
187− let combinedSpans =
189+ let combinedSpans = case style of
190+ Function name -> combineSrcSpans (getLoc name) patSpans
191+ _ -> patSpans
188− combineSrcSpans' $
192+ patSpans = combineSrcSpans' (getLoc <$> ne_pats)
189− getLoc <$> ne_pats
190− inci' =
191− if isOneLineSpan combinedSpans
193+ indentBody = not (isOneLineSpan combinedSpans)
192− then id
193− else inci
194 switchLayout [combinedSpans] $ do
194 switchLayout [combinedSpans] $ do
195 let stdCase = sep breakpoint (located' p_pat) m_pats
195 let stdCase = sep breakpoint (located' p_pat) m_pats
196 case style of
196 case style of
197 Function name ->
197 Function name ->
198 p_infixDefHelper
198 p_infixDefHelper
199 isInfix
199 isInfix
200− inci'
200+ indentBody
201 (p_rdrName name)
201 (p_rdrName name)
202 (located' p_pat <$> m_pats)
202 (located' p_pat <$> m_pats)
203 PatternBind -> stdCase
203 PatternBind -> stdCase
@@ -212,40 +212,32 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
212 when needsSpace space
212 when needsSpace space
213 sitcc stdCase
213 sitcc stdCase
214 LambdaCase -> stdCase
214 LambdaCase -> stdCase
215− return inci'
215+ return indentBody
216 let -- Calculate position of end of patterns. This is useful when we decide
216 let -- Calculate position of end of patterns. This is useful when we decide
217 -- about putting certain constructions in hanging positions.
217 -- about putting certain constructions in hanging positions.
218 endOfPats = case NE.nonEmpty m_pats of
218 endOfPats = case NE.nonEmpty m_pats of
219 Nothing -> case style of
219 Nothing -> case style of
220− Function name -> (Just . srcSpanEnd . getLoc) name
220+ Function name -> Just (getLoc name)
221 _ -> Nothing
221 _ -> Nothing
222− Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
222+ Just pats -> (Just . getLoc . NE.last) pats
223 isCase = \case
223 isCase = \case
224 Case -> True
224 Case -> True
225 LambdaCase -> True
225 LambdaCase -> True
226 _ -> False
226 _ -> False
227− let GRHSs {..} = m_grhss
228 hasGuards = withGuards grhssGRHSs
227 hasGuards = withGuards grhssGRHSs
229− unless (length grhssGRHSs > 1) $ do
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 "->"
236− let grhssSpan =
228+ grhssSpan =
237 combineSrcSpans' $
229 combineSrcSpans' $
238 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
230 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
239 patGrhssSpan =
231 patGrhssSpan =
232+ maybe
240− maybe grhssSpan
233+ grhssSpan
241− (combineSrcSpans grhssSpan . srcLocSpan)
234+ (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)
242 endOfPats
235 endOfPats
243 placement =
236 placement =
244 case endOfPats of
237 case endOfPats of
245 Nothing -> blockPlacement placer grhssGRHSs
238 Nothing -> blockPlacement placer grhssGRHSs
246 Just spn ->
239 Just spn ->
247− if isOneLineSpan
248− (mkSrcSpan spn (srcSpanStart grhssSpan))
240+ if onTheSameLine spn grhssSpan
249 then blockPlacement placer grhssGRHSs
241 then blockPlacement placer grhssGRHSs
250 else Normal
242 else Normal
251 p_body = do
243 p_body = do
@@ -261,10 +253,18 @@ p_match' placer render style isInfix strictness m_pats m_grhss = do
261 txt "where"
253 txt "where"
262 unless whereIsEmpty breakpoint
254 unless whereIsEmpty breakpoint
263 inci $ located grhssLocalBinds p_hsLocalBinds
255 inci $ located grhssLocalBinds p_hsLocalBinds
264− inci' $ do
256+ inciIf indentBody $ do
257+ unless (length grhssGRHSs > 1) $
258+ case style of
259+ Function _ | hasGuards -> return ()
260+ Function _ -> space >> inci equals
261+ PatternBind -> space >> inci equals
262+ s | isCase s && hasGuards -> return ()
263+ _ -> space >> txt "->"
265 switchLayout [patGrhssSpan] $
264 switchLayout [patGrhssSpan] $
266 placeHanging placement p_body
265 placeHanging placement p_body
267 inci p_where
266 inci p_where
267+p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
268
268
269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
270p_grhs = p_grhs' exprPlacement p_hsExpr
270p_grhs = p_grhs' exprPlacement p_hsExpr
@@ -278,79 +278,109 @@ p_grhs' ::
278 GroupStyle ->
278 GroupStyle ->
279 GRHS GhcPs (Located body) ->
279 GRHS GhcPs (Located body) ->
280 R ()
280 R ()
281−p_grhs' placer render style (GRHS NoExt guards body) =
281+p_grhs' placer render style (GRHS NoExtField guards body) =
282 case guards of
282 case guards of
283 [] -> p_body
283 [] -> p_body
284 xs -> do
284 xs -> do
285 txt "|"
285 txt "|"
286 space
286 space
287− sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
287+ sitcc (sep commaDel (sitcc . located' p_stmt) xs)
288 space
288 space
289− txt $ case style of
289+ inci $ case style of
290− EqualSign -> "="
290+ EqualSign -> equals
291− RightArrow -> "->"
291+ RightArrow -> txt "->"
292 placeHanging placement p_body
292 placeHanging placement p_body
293 where
293 where
294 placement =
294 placement =
295 case endOfGuards of
295 case endOfGuards of
296 Nothing -> placer (unLoc body)
296 Nothing -> placer (unLoc body)
297 Just spn ->
297 Just spn ->
298− if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
298+ if onTheSameLine spn (getLoc body)
299 then placer (unLoc body)
299 then placer (unLoc body)
300 else Normal
300 else Normal
301 endOfGuards =
301 endOfGuards =
302 case NE.nonEmpty guards of
302 case NE.nonEmpty guards of
303 Nothing -> Nothing
303 Nothing -> Nothing
304− Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
304+ Just gs -> (Just . getLoc . NE.last) gs
305 p_body = located body render
305 p_body = located body render
306−p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
306+p_grhs' _ _ _ (XGRHS x) = noExtCon x
307
307
308p_hsCmd :: HsCmd GhcPs -> R ()
308p_hsCmd :: HsCmd GhcPs -> R ()
309p_hsCmd = \case
309p_hsCmd = \case
310− HsCmdArrApp NoExt body input arrType _ -> do
310+ HsCmdArrApp NoExtField body input arrType _ -> do
311 located body p_hsExpr
311 located body p_hsExpr
312− space
312+ breakpoint
313+ inci $ do
313− case arrType of
314+ case arrType of
314− HsFirstOrderApp -> txt "-<"
315+ HsFirstOrderApp -> txt "-<"
315− HsHigherOrderApp -> txt "-<<"
316+ HsHigherOrderApp -> txt "-<<"
316− placeHanging (exprPlacement (unLoc input)) $
317+ placeHanging (exprPlacement (unLoc input)) $
317− located input p_hsExpr
318+ located input p_hsExpr
318− HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
319+ HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do
319 located form p_hsExpr
320 located form p_hsExpr
320 unless (null cmds) $ do
321 unless (null cmds) $ do
321 breakpoint
322 breakpoint
322 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
323 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
323− HsCmdArrForm NoExt form Infix _ [left, right] -> do
324+ HsCmdArrForm NoExtField form Infix _ [left, right] -> do
324 located left p_hsCmdTop
325 located left p_hsCmdTop
325 space
326 space
326 located form p_hsExpr
327 located form p_hsExpr
327 placeHanging (cmdTopPlacement (unLoc right)) $
328 placeHanging (cmdTopPlacement (unLoc right)) $
328 located right p_hsCmdTop
329 located right p_hsCmdTop
329− HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
330+ HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
330 HsCmdApp {} ->
331 HsCmdApp {} ->
331 -- XXX Does this ever occur in the syntax tree? It does not seem like it
332 -- XXX Does this ever occur in the syntax tree? It does not seem like it
332 -- does. Open an issue and ping @yumiova if this ever occurs in output.
333 -- does. Open an issue and ping @yumiova if this ever occurs in output.
333 notImplemented "HsCmdApp"
334 notImplemented "HsCmdApp"
334− HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
335+ HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
335− HsCmdPar NoExt c -> parens N (located c p_hsCmd)
336+ HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
336− HsCmdCase NoExt e mgroup ->
337+ HsCmdCase NoExtField e mgroup ->
337 p_case cmdPlacement p_hsCmd e mgroup
338 p_case cmdPlacement p_hsCmd e mgroup
338− HsCmdIf NoExt _ if' then' else' ->
339+ HsCmdIf NoExtField _ if' then' else' ->
339 p_if cmdPlacement p_hsCmd if' then' else'
340 p_if cmdPlacement p_hsCmd if' then' else'
340− HsCmdLet NoExt localBinds c ->
341+ HsCmdLet NoExtField localBinds c ->
341 p_let p_hsCmd localBinds c
342 p_let p_hsCmd localBinds c
342− HsCmdDo NoExt es -> do
343+ HsCmdDo NoExtField es -> do
343 txt "do"
344 txt "do"
344 newline
345 newline
345 inci . located es $
346 inci . located es $
346− sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
347+ sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))
347 HsCmdWrap {} -> notImplemented "HsCmdWrap"
348 HsCmdWrap {} -> notImplemented "HsCmdWrap"
348− XCmd {} -> notImplemented "XCmd"
349+ XCmd x -> noExtCon x
349
350
350p_hsCmdTop :: HsCmdTop GhcPs -> R ()
351p_hsCmdTop :: HsCmdTop GhcPs -> R ()
351p_hsCmdTop = \case
352p_hsCmdTop = \case
352− HsCmdTop NoExt cmd -> located cmd p_hsCmd
353+ HsCmdTop NoExtField cmd -> located cmd p_hsCmd
353− XCmdTop {} -> notImplemented "XHsCmdTop"
354+ XCmdTop x -> noExtCon x
355+
356+-- | Render an expression preserving blank lines between such consecutive
357+-- expressions found in the original source code.
358+withSpacing ::
359+ -- | Rendering function
360+ (a -> R ()) ->
361+ -- | Entity to render
362+ Located a ->
363+ R ()
364+withSpacing f l = located l $ \x -> do
365+ case getLoc l of
366+ UnhelpfulSpan _ -> f x
367+ RealSrcSpan currentSpn -> do
368+ getSpanMark >>= \case
369+ -- Spacing before comments will be handled by the code
370+ -- that prints comments, so we just have to deal with
371+ -- blank lines between statements here.
372+ Just (StatementSpan lastSpn) ->
373+ if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1
374+ then newline
375+ else return ()
376+ _ -> return ()
377+ f x
378+ -- In some cases the (f x) expression may insert a new mark. We want
379+ -- to be careful not to override comment marks.
380+ getSpanMark >>= \case
381+ Just (HaddockSpan _ _) -> return ()
382+ Just (CommentSpan _) -> return ()
383+ _ -> setSpanMark (StatementSpan currentSpn)
354
384
355p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
385p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
356p_stmt = p_stmt' exprPlacement p_hsExpr
386p_stmt = p_stmt' exprPlacement p_hsExpr
@@ -365,35 +395,36 @@ p_stmt' ::
365 Stmt GhcPs (Located body) ->
395 Stmt GhcPs (Located body) ->
366 R ()
396 R ()
367p_stmt' placer render = \case
397p_stmt' placer render = \case
368− LastStmt NoExt body _ _ -> located body render
398+ LastStmt NoExtField body _ _ -> located body render
369− BindStmt NoExt l f _ _ -> do
399+ BindStmt NoExtField p f _ _ -> do
370− located l p_pat
400+ located p p_pat
371 space
401 space
372 txt "<-"
402 txt "<-"
403+ let loc = getLoc p
373− let placement =
404+ placement =
374 case f of
405 case f of
375 L l' x ->
406 L l' x ->
376 if isOneLineSpan
407 if isOneLineSpan
377− (mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))
408+ (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l'))
378 then placer x
409 then placer x
379 else Normal
410 else Normal
380− switchLayout [getLoc l, getLoc f] $
411+ switchLayout [loc, getLoc f] $
381 placeHanging placement (located f render)
412 placeHanging placement (located f render)
382 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
413 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
383− BodyStmt NoExt body _ _ -> located body render
414+ BodyStmt NoExtField body _ _ -> located body render
384− LetStmt NoExt binds -> do
415+ LetStmt NoExtField binds -> do
385 txt "let"
416 txt "let"
386 space
417 space
387 sitcc $ located binds p_hsLocalBinds
418 sitcc $ located binds p_hsLocalBinds
388 ParStmt {} ->
419 ParStmt {} ->
389− -- NOTE 'ParStmt' should always be eliminated in 'gatherStmt' already,
420+ -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such
390− -- such that it never occurs in 'p_stmt''. Consequently, handling it
421+ -- that it never occurs in 'p_stmt''. Consequently, handling it here
391− -- here would be redundant.
422+ -- would be redundant.
392 notImplemented "ParStmt"
423 notImplemented "ParStmt"
393− TransStmt {..} -> do
424+ TransStmt {..} ->
394− -- NOTE 'TransStmt' only needs to account for render printing itself,
425+ -- 'TransStmt' only needs to account for render printing itself, since
395− -- since pretty printing of relevant statements (e.g., in 'trS_stmts')
426+ -- pretty printing of relevant statements (e.g., in 'trS_stmts') is
396− -- is handled through 'gatherStmt'.
427+ -- handled through 'gatherStmt'.
397 case (trS_form, trS_by) of
428 case (trS_form, trS_by) of
398 (ThenForm, Nothing) -> do
429 (ThenForm, Nothing) -> do
399 txt "then"
430 txt "then"
@@ -422,11 +453,11 @@ p_stmt' placer render = \case
422 RecStmt {..} -> do
453 RecStmt {..} -> do
423 txt "rec"
454 txt "rec"
424 space
455 space
425− sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
456+ sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
426− XStmtLR {} -> notImplemented "XStmtLR"
457+ XStmtLR c -> noExtCon c
427
458
428gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
459gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
429−gatherStmt (L _ (ParStmt NoExt block _ _)) =
460+gatherStmt (L _ (ParStmt NoExtField block _ _)) =
430 foldr ((<>) . gatherStmtBlock) [] block
461 foldr ((<>) . gatherStmtBlock) [] block
431gatherStmt (L s stmt@TransStmt {..}) =
462gatherStmt (L s stmt@TransStmt {..}) =
432 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
463 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
@@ -435,184 +466,229 @@ gatherStmt stmt = [[stmt]]
435gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
466gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
436gatherStmtBlock (ParStmtBlock _ stmts _ _) =
467gatherStmtBlock (ParStmtBlock _ stmts _ _) =
437 foldr (liftAppend . gatherStmt) [] stmts
468 foldr (liftAppend . gatherStmt) [] stmts
438−gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
469+gatherStmtBlock (XParStmtBlock x) = noExtCon x
439
470
440p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
441p_hsLocalBinds = \case
472p_hsLocalBinds = \case
442− HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
473+ HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
443− let ssStart =
444− either
445− (srcSpanStart . getLoc)
446− (srcSpanStart . getLoc)
447− items =
448− (Left <$> bagToList bag) ++ (Right <$> lsigs)
449− p_item (Left x) = located x p_valDecl
450− p_item (Right x) = located x p_sigDecl
451− -- Assigns 'False' to the last element, 'True' to the rest.
452− markInit :: [a] -> [(Bool, a)]
453− markInit [] = []
454− markInit (x : []) = [(False, x)]
455− markInit (x : xs) = (True, x) : markInit xs
456− -- NOTE When in a single-line layout, there is a chance that the inner
474+ -- When in a single-line layout, there is a chance that the inner
457 -- elements will also contain semicolons and they will confuse the
475 -- elements will also contain semicolons and they will confuse the
458 -- parser. so we request braces around every element except the last.
476 -- parser. so we request braces around every element except the last.
459 br <- layoutToBraces <$> getLayout
477 br <- layoutToBraces <$> getLayout
460− sitcc $
478+ let items =
461− sepSemi
479+ let injectLeft (L l x) = L l (Left x)
462− (\(m, i) -> (if m then br else id) $ p_item i)
480+ injectRight (L l x) = L l (Right x)
463− (markInit $ sortOn ssStart items)
481+ in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)
482+ positionToBracing = \case
483+ SinglePos -> id
484+ FirstPos -> br
485+ MiddlePos -> br
486+ LastPos -> id
487+ p_item' (p, item) =
488+ positionToBracing p $
489+ withSpacing (either p_valDecl p_sigDecl) item
490+ binds = sortOn (srcSpanStart . getLoc) items
491+ sitcc $ sepSemi p_item' (attachRelativePos binds)
464− HsValBinds NoExt _ -> notImplemented "HsValBinds"
492+ HsValBinds NoExtField _ -> notImplemented "HsValBinds"
465− HsIPBinds NoExt (IPBinds NoExt xs) ->
493+ HsIPBinds NoExtField (IPBinds NoExtField xs) ->
466 -- Second argument of IPBind is always Left before type-checking.
494 -- Second argument of IPBind is always Left before type-checking.
467− let p_ipBind (IPBind NoExt (Left name) expr) = do
495+ let p_ipBind (IPBind NoExtField (Left name) expr) = do
468 atom name
496 atom name
469 space
497 space
470− txt "="
498+ equals
471 breakpoint
499 breakpoint
472 useBraces $ inci $ located expr p_hsExpr
500 useBraces $ inci $ located expr p_hsExpr
501+ p_ipBind (IPBind NoExtField (Right _) _) =
502+ -- Should only occur after the type checker
473− p_ipBind _ = notImplemented "XHsIPBinds"
503+ notImplemented "IPBind _ (Right _) _"
504+ p_ipBind (XIPBind x) = noExtCon x
474 in sepSemi (located' p_ipBind) xs
505 in sepSemi (located' p_ipBind) xs
475− HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
506+ HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
476− EmptyLocalBinds NoExt -> return ()
507+ EmptyLocalBinds NoExtField -> return ()
477− XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
508+ XHsLocalBindsLR x -> noExtCon x
478
509
479p_hsRecField ::
510p_hsRecField ::
480 HsRecField' RdrName (LHsExpr GhcPs) ->
511 HsRecField' RdrName (LHsExpr GhcPs) ->
481 R ()
512 R ()
482−p_hsRecField = \HsRecField {..} -> do
513+p_hsRecField HsRecField {..} = do
483 p_rdrName hsRecFieldLbl
514 p_rdrName hsRecFieldLbl
484 unless hsRecPun $ do
515 unless hsRecPun $ do
485 space
516 space
486− txt "="
517+ equals
518+ let placement =
519+ if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)
487− let placement = exprPlacement (unLoc hsRecFieldArg)
520+ then exprPlacement (unLoc hsRecFieldArg)
521+ else Normal
488− placeHanging placement $ located hsRecFieldArg p_hsExpr
522+ placeHanging placement (located hsRecFieldArg p_hsExpr)
489−
490−p_hsTupArg :: HsTupArg GhcPs -> R ()
491−p_hsTupArg = \case
492− Present NoExt x -> located x p_hsExpr
493− Missing NoExt -> pure ()
494− XTupArg {} -> notImplemented "XTupArg"
495
523
496p_hsExpr :: HsExpr GhcPs -> R ()
524p_hsExpr :: HsExpr GhcPs -> R ()
497p_hsExpr = p_hsExpr' N
525p_hsExpr = p_hsExpr' N
498
526
499p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
527p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
500p_hsExpr' s = \case
528p_hsExpr' s = \case
501− HsVar NoExt name -> p_rdrName name
529+ HsVar NoExtField name -> p_rdrName name
502− HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
530+ HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
503− HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
531+ HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
504− HsRecFld NoExt x ->
532+ HsRecFld NoExtField x ->
505 case x of
533 case x of
506− Unambiguous NoExt name -> p_rdrName name
534+ Unambiguous NoExtField name -> p_rdrName name
507− Ambiguous NoExt name -> p_rdrName name
535+ Ambiguous NoExtField name -> p_rdrName name
508− XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
536+ XAmbiguousFieldOcc xx -> noExtCon xx
509− HsOverLabel NoExt _ v -> do
537+ HsOverLabel NoExtField _ v -> do
510 txt "#"
538 txt "#"
511 atom v
539 atom v
512− HsIPVar NoExt (HsIPName name) -> do
540+ HsIPVar NoExtField (HsIPName name) -> do
513 txt "?"
541 txt "?"
514 atom name
542 atom name
515− HsOverLit NoExt v -> atom (ol_val v)
543+ HsOverLit NoExtField v -> atom (ol_val v)
516− HsLit NoExt lit ->
544+ HsLit NoExtField lit ->
517 case lit of
545 case lit of
518 HsString (SourceText stxt) _ -> p_stringLit stxt
546 HsString (SourceText stxt) _ -> p_stringLit stxt
519 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
547 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
520 r -> atom r
548 r -> atom r
521− HsLam NoExt mgroup ->
549+ HsLam NoExtField mgroup ->
522 p_matchGroup Lambda mgroup
550 p_matchGroup Lambda mgroup
523− HsLamCase NoExt mgroup -> do
551+ HsLamCase NoExtField mgroup -> do
524 txt "\\case"
552 txt "\\case"
525 breakpoint
553 breakpoint
526 inci (p_matchGroup LambdaCase mgroup)
554 inci (p_matchGroup LambdaCase mgroup)
527− HsApp NoExt f x -> do
555+ HsApp NoExtField f x -> do
528− -- We hang only the last function argument. In order to do this, we only
556+ let -- In order to format function applications with multiple parameters
529− -- call 'placeHanging' on the topmost 'HsApp', and then use
557+ -- nicer, traverse the AST to gather the function and all the
530− -- 'p_withoutHanging' for the descendants.
558+ -- parameters together.
531− let p_withoutHanging (HsApp NoExt f' x') = do
559+ gatherArgs f' knownArgs =
532 case f' of
560 case f' of
533− L _ (HsApp _ _ _) -> located f' p_withoutHanging
561+ L _ (HsApp _ l r) -> gatherArgs l (r <| knownArgs)
534− _ -> located f' (p_hsExpr' s)
562+ _ -> (f', knownArgs)
535− breakpoint
563+ (func, args) = gatherArgs f (x :| [])
536− inci $ located x' p_hsExpr
564+ -- We need to handle the last argument specially if it is a
537− p_withoutHanging e = p_hsExpr e
565+ -- hanging construct, so separate it from the rest.
538− -- Only use the hanging placement if the function spans a single
566+ (initp, lastp) = (NE.init args, NE.last args)
567+ initSpan =
568+ combineSrcSpans' $
569+ getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]
570+ -- Hang the last argument only if the initial arguments span one
539 -- line.
571 -- line.
540 placement =
572 placement =
541− if isOneLineSpan (getLoc f)
573+ if isOneLineSpan initSpan
542− then exprPlacement (unLoc x)
574+ then exprPlacement (unLoc lastp)
543 else Normal
575 else Normal
544− useBraces (located f p_withoutHanging)
576+ -- If the last argument is not hanging, just separate every argument as
577+ -- usual. If it is hanging, print the initial arguments and hang the
578+ -- last one. Also, use braces around the every argument except the last
579+ -- one.
580+ case placement of
581+ Normal -> do
582+ let -- Usually we want to bump indentation for arguments for the
583+ -- sake of readability. However, when the function itself is a
584+ -- do-block or case expression it is not a good idea. It seems
585+ -- to be safe to always bump indentation when the function
586+ -- expression is parenthesised.
587+ doIndent =
588+ case func of
589+ L _ (HsPar NoExtField _) -> True
590+ L _ (HsAppType NoExtField _ _) -> True
591+ L _ (HsMultiIf NoExtField _) -> True
592+ L spn _ -> isOneLineSpan spn
593+ ub <-
594+ getLayout <&> \case
595+ SingleLine -> useBraces
596+ MultiLine -> id
597+ ub $ do
598+ located func (p_hsExpr' s)
599+ breakpoint
600+ inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601+ inciIf doIndent $ do
602+ unless (null initp) breakpoint
603+ located lastp p_hsExpr
604+ Hanging -> do
605+ useBraces . switchLayout [initSpan] $ do
606+ located func (p_hsExpr' s)
607+ breakpoint
608+ sep breakpoint (located' p_hsExpr) initp
545− placeHanging placement $
609+ placeHanging placement $
546− located x p_hsExpr
610+ located lastp p_hsExpr
547− HsAppType a e -> do
611+ HsAppType NoExtField e a -> do
548 located e p_hsExpr
612 located e p_hsExpr
549 breakpoint
613 breakpoint
550 inci $ do
614 inci $ do
551 txt "@"
615 txt "@"
616+ -- Insert a space when the type is represented as a TH splice to avoid
617+ -- gluing @ and $ together.
618+ case unLoc (hswc_body a) of
619+ HsSpliceTy {} -> space
620+ _ -> return ()
552 located (hswc_body a) p_hsType
621 located (hswc_body a) p_hsType
553− OpApp NoExt x op y -> do
622+ OpApp NoExtField x op y -> do
554 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
555− p_exprOpTree True s (reassociateOpTree getOpName opTree)
624+ p_exprOpTree s (reassociateOpTree getOpName opTree)
556− NegApp NoExt e _ -> do
625+ NegApp NoExtField e _ -> do
557 txt "-"
626 txt "-"
558 space
627 space
559 located e p_hsExpr
628 located e p_hsExpr
560− HsPar NoExt e ->
629+ HsPar NoExtField e ->
561 parens s (located e (dontUseBraces . p_hsExpr))
630 parens s (located e (dontUseBraces . p_hsExpr))
562− SectionL NoExt x op -> do
631+ SectionL NoExtField x op -> do
563 located x p_hsExpr
632 located x p_hsExpr
564 breakpoint
633 breakpoint
565 inci (located op p_hsExpr)
634 inci (located op p_hsExpr)
566− SectionR NoExt op x -> do
635+ SectionR NoExtField op x -> do
567 located op p_hsExpr
636 located op p_hsExpr
637+ useRecordDot' <- useRecordDot
638+ let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
568− breakpoint
639+ unless (useRecordDot' && isRecordDot') breakpoint
569 inci (located x p_hsExpr)
640 inci (located x p_hsExpr)
570− ExplicitTuple NoExt args boxity -> do
641+ ExplicitTuple NoExtField args boxity ->
571 let isSection = any (isMissing . unLoc) args
642 let isSection = any (isMissing . unLoc) args
572 isMissing = \case
643 isMissing = \case
573− Missing NoExt -> True
644+ Missing NoExtField -> True
574 _ -> False
645 _ -> False
646+ p_arg = \case
647+ Present NoExtField x -> located x p_hsExpr
648+ Missing NoExtField -> pure ()
649+ XTupArg x -> noExtCon x
650+ p_larg = sitcc . located' p_arg
575− let parens' =
651+ parens' =
576 case boxity of
652 case boxity of
577 Boxed -> parens
653 Boxed -> parens
578 Unboxed -> parensHash
654 Unboxed -> parensHash
579− if isSection
655+ in if isSection
580− then
656+ then
581− switchLayout [] . parens' s $
657+ switchLayout [] . parens' s $
582− sep comma (located' p_hsTupArg) args
658+ sep comma p_larg args
583− else
659+ else
584− switchLayout (getLoc <$> args) . parens' s . sitcc $
660+ switchLayout (getLoc <$> args) . parens' s $
585− sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
661+ sep commaDel p_larg args
586− ExplicitSum NoExt tag arity e ->
662+ ExplicitSum NoExtField tag arity e ->
587 p_unboxedSum N tag arity (located e p_hsExpr)
663 p_unboxedSum N tag arity (located e p_hsExpr)
588− HsCase NoExt e mgroup ->
664+ HsCase NoExtField e mgroup ->
589 p_case exprPlacement p_hsExpr e mgroup
665 p_case exprPlacement p_hsExpr e mgroup
590− HsIf NoExt _ if' then' else' ->
666+ HsIf NoExtField _ if' then' else' ->
591 p_if exprPlacement p_hsExpr if' then' else'
667 p_if exprPlacement p_hsExpr if' then' else'
592− HsMultiIf NoExt guards -> do
668+ HsMultiIf NoExtField guards -> do
593 txt "if"
669 txt "if"
594 breakpoint
670 breakpoint
595− inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
671+ inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
596− HsLet NoExt localBinds e ->
672+ HsLet NoExtField localBinds e ->
597 p_let p_hsExpr localBinds e
673 p_let p_hsExpr localBinds e
598− HsDo NoExt ctx es -> do
674+ HsDo NoExtField ctx es -> do
599 let doBody header = do
675 let doBody header = do
600 txt header
676 txt header
601 breakpoint
677 breakpoint
602 ub <- layoutToBraces <$> getLayout
678 ub <- layoutToBraces <$> getLayout
603 inci $
679 inci $
604 sepSemi
680 sepSemi
605− (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
681+ (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
606 (unLoc es)
682 (unLoc es)
607− compBody = brackets N $ located es $ \xs -> do
683+ compBody = brackets N . located es $ \xs -> do
608 let p_parBody =
684 let p_parBody =
609 sep
685 sep
610− (breakpoint >> txt "| ")
686+ (breakpoint >> txt "|" >> space)
611 p_seqBody
687 p_seqBody
612 p_seqBody =
688 p_seqBody =
613 sitcc
689 sitcc
614 . sep
690 . sep
615− (comma >> breakpoint)
691+ commaDel
616 (located' (sitcc . p_stmt))
692 (located' (sitcc . p_stmt))
617 stmts = init xs
693 stmts = init xs
618 yield = last xs
694 yield = last xs
@@ -633,88 +709,94 @@ p_hsExpr' s = \case
633 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
634 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
635 ExplicitList _ _ xs ->
711 ExplicitList _ _ xs ->
636− brackets s . sitcc $
712+ brackets s $
637− sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
713+ sep commaDel (sitcc . located' p_hsExpr) xs
638 RecordCon {..} -> do
714 RecordCon {..} -> do
639 located rcon_con_name atom
715 located rcon_con_name atom
640 breakpoint
716 breakpoint
641 let HsRecFields {..} = rcon_flds
717 let HsRecFields {..} = rcon_flds
642 updName f =
718 updName f =
643− f
719+ (f :: HsRecField GhcPs (LHsExpr GhcPs))
644 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
720 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
645 FieldOcc _ n -> n
721 FieldOcc _ n -> n
646− XFieldOcc _ -> notImplemented "XFieldOcc"
722+ XFieldOcc x -> noExtCon x
647 }
723 }
648 fields = located' (p_hsRecField . updName) <$> rec_flds
724 fields = located' (p_hsRecField . updName) <$> rec_flds
649 dotdot =
725 dotdot =
650 case rec_dotdot of
726 case rec_dotdot of
651 Just {} -> [txt ".."]
727 Just {} -> [txt ".."]
652 Nothing -> []
728 Nothing -> []
653− inci . braces N . sitcc $
729+ inci . braces N $
654− sep (comma >> breakpoint) sitcc (fields <> dotdot)
730+ sep commaDel sitcc (fields <> dotdot)
655 RecordUpd {..} -> do
731 RecordUpd {..} -> do
656 located rupd_expr p_hsExpr
732 located rupd_expr p_hsExpr
733+ useRecordDot' <- useRecordDot
734+ let mrs sp = case getLoc sp of
735+ RealSrcSpan r -> Just r
736+ _ -> Nothing
737+ let isPluginForm =
738+ ((1 +) . srcSpanEndCol <$> mrs rupd_expr)
739+ == (srcSpanStartCol <$> mrs (head rupd_flds))
657− breakpoint
740+ unless (useRecordDot' && isPluginForm) breakpoint
658 let updName f =
741 let updName f =
659− f
742+ (f :: HsRecUpdField GhcPs)
660 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
743 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
661 Ambiguous _ n -> n
744 Ambiguous _ n -> n
662 Unambiguous _ n -> n
745 Unambiguous _ n -> n
663− XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
746+ XAmbiguousFieldOcc x -> noExtCon x
664 }
747 }
665− inci . braces N . sitcc $
748+ inci . braces N $
666 sep
749 sep
667− (comma >> breakpoint)
750+ commaDel
668 (sitcc . located' (p_hsRecField . updName))
751 (sitcc . located' (p_hsRecField . updName))
669 rupd_flds
752 rupd_flds
670− ExprWithTySig affix x -> sitcc $ do
753+ ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
671 located x p_hsExpr
754 located x p_hsExpr
672 space
755 space
673 txt "::"
756 txt "::"
674 breakpoint
757 breakpoint
675− inci $ do
676− let HsWC {..} = affix
677− HsIB {..} = hswc_body
678− located hsib_body p_hsType
758+ inci $ located hsib_body p_hsType
759+ ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
760+ ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
679− ArithSeq NoExt _ x -> do
761+ ArithSeq NoExtField _ x ->
680 case x of
762 case x of
681− From from -> brackets s . sitcc $ do
763+ From from -> brackets s $ do
682 located from p_hsExpr
764 located from p_hsExpr
683 breakpoint
765 breakpoint
684 txt ".."
766 txt ".."
685− FromThen from next -> brackets s . sitcc $ do
767+ FromThen from next -> brackets s $ do
686− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
768+ sep commaDel (located' p_hsExpr) [from, next]
687 breakpoint
769 breakpoint
688 txt ".."
770 txt ".."
689− FromTo from to -> brackets s . sitcc $ do
771+ FromTo from to -> brackets s $ do
690 located from p_hsExpr
772 located from p_hsExpr
691 breakpoint
773 breakpoint
692 txt ".."
774 txt ".."
693 space
775 space
694 located to p_hsExpr
776 located to p_hsExpr
695− FromThenTo from next to -> brackets s . sitcc $ do
777+ FromThenTo from next to -> brackets s $ do
696− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
778+ sep commaDel (located' p_hsExpr) [from, next]
697 breakpoint
779 breakpoint
698 txt ".."
780 txt ".."
699 space
781 space
700 located to p_hsExpr
782 located to p_hsExpr
701− HsSCC NoExt _ name x -> do
783+ HsSCC NoExtField _ name x -> do
702 txt "{-# SCC "
784 txt "{-# SCC "
703 atom name
785 atom name
704 txt " #-}"
786 txt " #-}"
705 breakpoint
787 breakpoint
706 located x p_hsExpr
788 located x p_hsExpr
707− HsCoreAnn NoExt _ value x -> do
789+ HsCoreAnn NoExtField _ value x -> do
708 txt "{-# CORE "
790 txt "{-# CORE "
709 atom value
791 atom value
710 txt " #-}"
792 txt " #-}"
711 breakpoint
793 breakpoint
712 located x p_hsExpr
794 located x p_hsExpr
713− HsBracket NoExt x -> p_hsBracket x
795+ HsBracket NoExtField x -> p_hsBracket x
714 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
796 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
715 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
797 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
716− HsSpliceE NoExt splice -> p_hsSplice splice
798+ HsSpliceE NoExtField splice -> p_hsSplice splice
717− HsProc NoExt p e -> do
799+ HsProc NoExtField p e -> do
718 txt "proc"
800 txt "proc"
719 located p $ \x -> do
801 located p $ \x -> do
720 breakpoint
802 breakpoint
@@ -727,31 +809,11 @@ p_hsExpr' s = \case
727 txt "static"
809 txt "static"
728 breakpoint
810 breakpoint
729 inci (located e p_hsExpr)
811 inci (located e p_hsExpr)
730− HsArrApp NoExt body input arrType cond ->
731− p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
732− HsArrForm NoExt form mfixity cmds ->
733− p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
734 HsTick {} -> notImplemented "HsTick"
812 HsTick {} -> notImplemented "HsTick"
735 HsBinTick {} -> notImplemented "HsBinTick"
813 HsBinTick {} -> notImplemented "HsBinTick"
736 HsTickPragma {} -> notImplemented "HsTickPragma"
814 HsTickPragma {} -> notImplemented "HsTickPragma"
737− -- These four constructs should never appear in correct programs.
738− -- See: https://github.com/tweag/ormolu/issues/343
739− EWildPat NoExt -> txt "_"
740− EAsPat NoExt n p -> do
741− p_rdrName n
742− txt "@"
743− located p p_hsExpr
744− EViewPat NoExt p e -> do
745− located p p_hsExpr
746− space
747− txt "->"
748− breakpoint
749− inci (located e p_hsExpr)
750− ELazyPat NoExt p -> do
751− txt "~"
752− located p p_hsExpr
753 HsWrap {} -> notImplemented "HsWrap"
815 HsWrap {} -> notImplemented "HsWrap"
754− XExpr {} -> notImplemented "XExpr"
816+ XExpr x -> noExtCon x
755
817
756p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
818p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
757p_patSynBind PSB {..} = do
819p_patSynBind PSB {..} = do
@@ -763,7 +825,7 @@ p_patSynBind PSB {..} = do
763 breakpoint
825 breakpoint
764 located psb_def p_pat
826 located psb_def p_pat
765 ImplicitBidirectional -> do
827 ImplicitBidirectional -> do
766− txt "="
828+ equals
767 breakpoint
829 breakpoint
768 located psb_def p_pat
830 located psb_def p_pat
769 ExplicitBidirectional mgroup -> do
831 ExplicitBidirectional mgroup -> do
@@ -790,8 +852,8 @@ p_patSynBind PSB {..} = do
790 inci $ do
852 inci $ do
791 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
792 unless (null xs) breakpoint
854 unless (null xs) breakpoint
793− braces N . sitcc $
855+ braces N $
794− sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
856+ sep commaDel (p_rdrName . recordPatSynPatVar) xs
795 rhs
857 rhs
796 InfixCon l r -> do
858 InfixCon l r -> do
797 switchLayout [getLoc l, getLoc r] $ do
859 switchLayout [getLoc l, getLoc r] $ do
@@ -803,7 +865,7 @@ p_patSynBind PSB {..} = do
803 space
865 space
804 p_rdrName r
866 p_rdrName r
805 inci rhs
867 inci rhs
806−p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
868+p_patSynBind (XPatSynBind x) = noExtCon x
807
869
808p_case ::
870p_case ::
809 Data body =>
871 Data body =>
@@ -814,7 +876,7 @@ p_case ::
814 -- | Expression
876 -- | Expression
815 LHsExpr GhcPs ->
877 LHsExpr GhcPs ->
816 -- | Match group
878 -- | Match group
817− (MatchGroup GhcPs (Located body)) ->
879+ MatchGroup GhcPs (Located body) ->
818 R ()
880 R ()
819p_case placer render e mgroup = do
881p_case placer render e mgroup = do
820 txt "case"
882 txt "case"
@@ -845,10 +907,12 @@ p_if placer render if' then' else' = do
845 breakpoint
907 breakpoint
846 inci $ do
908 inci $ do
847 txt "then"
909 txt "then"
910+ space
848 located then' $ \x ->
911 located then' $ \x ->
849 placeHanging (placer x) (render x)
912 placeHanging (placer x) (render x)
850 breakpoint
913 breakpoint
851 txt "else"
914 txt "else"
915+ space
852 located else' $ \x ->
916 located else' $ \x ->
853 placeHanging (placer x) (render x)
917 placeHanging (placer x) (render x)
854
918
@@ -870,29 +934,29 @@ p_let render localBinds e = sitcc $ do
870
934
871p_pat :: Pat GhcPs -> R ()
935p_pat :: Pat GhcPs -> R ()
872p_pat = \case
936p_pat = \case
873− WildPat NoExt -> txt "_"
937+ WildPat NoExtField -> txt "_"
874− VarPat NoExt name -> p_rdrName name
938+ VarPat NoExtField name -> p_rdrName name
875− LazyPat NoExt pat -> do
939+ LazyPat NoExtField pat -> do
876 txt "~"
940 txt "~"
877 located pat p_pat
941 located pat p_pat
878− AsPat NoExt name pat -> do
942+ AsPat NoExtField name pat -> do
879 p_rdrName name
943 p_rdrName name
880 txt "@"
944 txt "@"
881 located pat p_pat
945 located pat p_pat
882− ParPat NoExt pat ->
946+ ParPat NoExtField pat ->
883 located pat (parens S . p_pat)
947 located pat (parens S . p_pat)
884− BangPat NoExt pat -> do
948+ BangPat NoExtField pat -> do
885 txt "!"
949 txt "!"
886 located pat p_pat
950 located pat p_pat
887− ListPat NoExt pats -> do
951+ ListPat NoExtField pats ->
888− brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
952+ brackets S $ sep commaDel (located' p_pat) pats
889− TuplePat NoExt pats boxing -> do
953+ TuplePat NoExtField pats boxing -> do
890− let f =
954+ let parens' =
891 case boxing of
955 case boxing of
892 Boxed -> parens S
956 Boxed -> parens S
893 Unboxed -> parensHash S
957 Unboxed -> parensHash S
894− f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
958+ parens' $ sep commaDel (sitcc . located' p_pat) pats
895− SumPat NoExt pat tag arity ->
959+ SumPat NoExtField pat tag arity ->
896 p_unboxedSum S tag arity (located pat p_pat)
960 p_unboxedSum S tag arity (located pat p_pat)
897 ConPatIn pat details ->
961 ConPatIn pat details ->
898 case details of
962 case details of
@@ -907,38 +971,40 @@ p_pat = \case
907 let f = \case
971 let f = \case
908 Nothing -> txt ".."
972 Nothing -> txt ".."
909 Just x -> located x p_pat_hsRecField
973 Just x -> located x p_pat_hsRecField
910− inci . braces N . sitcc . sep (comma >> breakpoint) f $
974+ inci . braces N . sep commaDel f $
911 case dotdot of
975 case dotdot of
912 Nothing -> Just <$> fields
976 Nothing -> Just <$> fields
913− Just n -> (Just <$> take n fields) ++ [Nothing]
977+ Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
914− InfixCon x y -> do
978+ InfixCon l r -> do
979+ switchLayout [getLoc l, getLoc r] $ do
915− located x p_pat
980+ located l p_pat
916− space
981+ breakpoint
982+ inci $ do
917− p_rdrName pat
983+ p_rdrName pat
918− breakpoint
984+ space
919− inci (located y p_pat)
985+ located r p_pat
920 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
986 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
921− ViewPat NoExt expr pat -> sitcc $ do
987+ ViewPat NoExtField expr pat -> sitcc $ do
922 located expr p_hsExpr
988 located expr p_hsExpr
923 space
989 space
924 txt "->"
990 txt "->"
925 breakpoint
991 breakpoint
926 inci (located pat p_pat)
992 inci (located pat p_pat)
927− SplicePat NoExt splice -> p_hsSplice splice
993+ SplicePat NoExtField splice -> p_hsSplice splice
928− LitPat NoExt p -> atom p
994+ LitPat NoExtField p -> atom p
929− NPat NoExt v _ _ -> located v (atom . ol_val)
995+ NPat NoExtField v _ _ -> located v (atom . ol_val)
930− NPlusKPat NoExt n k _ _ _ -> sitcc $ do
996+ NPlusKPat NoExtField n k _ _ _ -> sitcc $ do
931 p_rdrName n
997 p_rdrName n
932 breakpoint
998 breakpoint
933 inci $ do
999 inci $ do
934 txt "+"
1000 txt "+"
935 space
1001 space
936 located k (atom . ol_val)
1002 located k (atom . ol_val)
937− SigPat hswc pat -> do
1003+ SigPat NoExtField pat hswc -> do
938 located pat p_pat
1004 located pat p_pat
939 p_typeAscription hswc
1005 p_typeAscription hswc
940 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
1006 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
941− XPat NoExt -> notImplemented "XPat"
1007+ XPat x -> noExtCon x
942
1008
943p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
1009p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
944p_pat_hsRecField HsRecField {..} = do
1010p_pat_hsRecField HsRecField {..} = do
@@ -946,7 +1012,7 @@ p_pat_hsRecField HsRecField {..} = do
946 p_rdrName (rdrNameFieldOcc x)
1012 p_rdrName (rdrNameFieldOcc x)
947 unless hsRecPun $ do
1013 unless hsRecPun $ do
948 space
1014 space
949− txt "="
1015+ equals
950 breakpoint
1016 breakpoint
951 inci (located hsRecFieldArg p_pat)
1017 inci (located hsRecFieldArg p_pat)
952
1018
@@ -955,32 +1021,31 @@ p_unboxedSum s tag arity m = do
955 let before = tag - 1
1021 let before = tag - 1
956 after = arity - before - 1
1022 after = arity - before - 1
957 args = replicate before Nothing <> [Just m] <> replicate after Nothing
1023 args = replicate before Nothing <> [Just m] <> replicate after Nothing
958− f (x, i) = do
1024+ f x =
959− let isFirst = i == 0
960− isLast = i == arity - 1
961 case x :: Maybe (R ()) of
1025 case x :: Maybe (R ()) of
962 Nothing ->
1026 Nothing ->
963− unless (isFirst || isLast) space
1027+ space
964 Just m' -> do
1028 Just m' -> do
965− unless isFirst space
1029+ space
966 m'
1030 m'
967− unless isLast space
1031+ space
968− parensHash s $ sep (txt "|") f (zip args [0 ..])
1032+ parensHash s $ sep (txt "|") f args
969
1033
970p_hsSplice :: HsSplice GhcPs -> R ()
1034p_hsSplice :: HsSplice GhcPs -> R ()
971p_hsSplice = \case
1035p_hsSplice = \case
972− HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
1036+ HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco
973− HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
1037+ HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco
974− HsQuasiQuote NoExt _ quoterName srcSpan str -> do
1038+ HsQuasiQuote NoExtField _ quoterName srcSpan str -> do
975 txt "["
1039 txt "["
976 p_rdrName (L srcSpan quoterName)
1040 p_rdrName (L srcSpan quoterName)
977 txt "|"
1041 txt "|"
978− -- NOTE QuasiQuoters often rely on precise custom strings. We cannot do
1042+ -- QuasiQuoters often rely on precise custom strings. We cannot do any
979− -- any formatting here without potentially breaking someone's code.
1043+ -- formatting here without potentially breaking someone's code.
980 atom str
1044 atom str
981 txt "|]"
1045 txt "|]"
982 HsSpliced {} -> notImplemented "HsSpliced"
1046 HsSpliced {} -> notImplemented "HsSpliced"
983− XSplice {} -> notImplemented "XSplice"
1047+ HsSplicedT {} -> notImplemented "HsSplicedT"
1048+ XSplice x -> noExtCon x
984
1049
985p_hsSpliceTH ::
1050p_hsSpliceTH ::
986 -- | Typed splice?
1051 -- | Typed splice?
@@ -1004,17 +1069,17 @@ p_hsSpliceTH isTyped expr = \case
1004
1069
1005p_hsBracket :: HsBracket GhcPs -> R ()
1070p_hsBracket :: HsBracket GhcPs -> R ()
1006p_hsBracket = \case
1071p_hsBracket = \case
1007− ExpBr NoExt expr -> do
1072+ ExpBr NoExtField expr -> do
1008 anns <- getEnclosingAnns
1073 anns <- getEnclosingAnns
1009 let name = case anns of
1074 let name = case anns of
1010 AnnOpenEQ : _ -> ""
1075 AnnOpenEQ : _ -> ""
1011 _ -> "e"
1076 _ -> "e"
1012 quote name (located expr p_hsExpr)
1077 quote name (located expr p_hsExpr)
1013− PatBr NoExt pat -> quote "p" (located pat p_pat)
1078+ PatBr NoExtField pat -> located pat (quote "p" . p_pat)
1014− DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
1079+ DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)
1015− DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
1080+ DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer
1016− TypBr NoExt ty -> quote "t" (located ty p_hsType)
1081+ TypBr NoExtField ty -> quote "t" (located ty p_hsType)
1017− VarBr NoExt isSingleQuote name -> do
1082+ VarBr NoExtField isSingleQuote name -> do
1018 txt (bool "''" "'" isSingleQuote)
1083 txt (bool "''" "'" isSingleQuote)
1019 -- HACK As you can see we use 'noLoc' here to be able to pass name into
1084 -- HACK As you can see we use 'noLoc' here to be able to pass name into
1020 -- 'p_rdrName' since the latter expects a "located" thing. The problem
1085 -- 'p_rdrName' since the latter expects a "located" thing. The problem
@@ -1029,13 +1094,13 @@ p_hsBracket = \case
1029 && not (doesNotNeedExtraParens name)
1094 && not (doesNotNeedExtraParens name)
1030 wrapper = if isOperator then parens N else id
1095 wrapper = if isOperator then parens N else id
1031 wrapper $ p_rdrName (noLoc name)
1096 wrapper $ p_rdrName (noLoc name)
1032− TExpBr NoExt expr -> do
1097+ TExpBr NoExtField expr -> do
1033 txt "[||"
1098 txt "[||"
1034 breakpoint'
1099 breakpoint'
1035 located expr p_hsExpr
1100 located expr p_hsExpr
1036 breakpoint'
1101 breakpoint'
1037 txt "||]"
1102 txt "||]"
1038− XBracket {} -> notImplemented "XBracket"
1103+ XBracket x -> noExtCon x
1039 where
1104 where
1040 quote :: Text -> R () -> R ()
1105 quote :: Text -> R () -> R ()
1041 quote name body = do
1106 quote name body = do
@@ -1089,7 +1154,8 @@ p_stringLit src =
1089 zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
1154 zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
1090 zipPrevNext xs =
1155 zipPrevNext xs =
1091 let z =
1156 let z =
1157+ zip
1092− zip (zip (Nothing : map Just xs) xs)
1158+ (zip (Nothing : map Just xs) xs)
1093 (map Just (tail xs) ++ repeat Nothing)
1159 (map Just (tail xs) ++ repeat Nothing)
1094 in map (\((p, x), n) -> (p, x, n)) z
1160 in map (\((p, x), n) -> (p, x, n)) z
1095 orig (_, x, _) = x
1161 orig (_, x, _) = x
@@ -1113,9 +1179,9 @@ liftAppend (x : xs) [] = x : xs
1113liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
1179liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
1114
1180
1115getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
1181getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
1116−getGRHSSpan (GRHS NoExt guards body) =
1182+getGRHSSpan (GRHS NoExtField guards body) =
1117 combineSrcSpans' $ getLoc body :| map getLoc guards
1183 combineSrcSpans' $ getLoc body :| map getLoc guards
1118−getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
1184+getGRHSSpan (XGRHS x) = noExtCon x
1119
1185
1120-- | Place a thing that may have a hanging form. This function handles how
1186-- | Place a thing that may have a hanging form. This function handles how
1121-- to separate it from preceding expressions and whether to bump indentation
1187-- to separate it from preceding expressions and whether to bump indentation
@@ -1136,46 +1202,44 @@ blockPlacement ::
1136 (body -> Placement) ->
1202 (body -> Placement) ->
1137 [LGRHS GhcPs (Located body)] ->
1203 [LGRHS GhcPs (Located body)] ->
1138 Placement
1204 Placement
1139−blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
1205+blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
1140blockPlacement _ _ = Normal
1206blockPlacement _ _ = Normal
1141
1207
1142-- | Check if given command has a hanging form.
1208-- | Check if given command has a hanging form.
1143cmdPlacement :: HsCmd GhcPs -> Placement
1209cmdPlacement :: HsCmd GhcPs -> Placement
1144cmdPlacement = \case
1210cmdPlacement = \case
1145− HsCmdLam NoExt _ -> Hanging
1211+ HsCmdLam NoExtField _ -> Hanging
1146− HsCmdCase NoExt _ _ -> Hanging
1212+ HsCmdCase NoExtField _ _ -> Hanging
1147− HsCmdDo NoExt _ -> Hanging
1213+ HsCmdDo NoExtField _ -> Hanging
1148 _ -> Normal
1214 _ -> Normal
1149
1215
1150cmdTopPlacement :: HsCmdTop GhcPs -> Placement
1216cmdTopPlacement :: HsCmdTop GhcPs -> Placement
1151cmdTopPlacement = \case
1217cmdTopPlacement = \case
1152− HsCmdTop NoExt (L _ x) -> cmdPlacement x
1218+ HsCmdTop NoExtField (L _ x) -> cmdPlacement x
1153− XCmdTop {} -> notImplemented "XCmdTop"
1219+ XCmdTop x -> noExtCon x
1154
1220
1155-- | Check if given expression has a hanging form.
1221-- | Check if given expression has a hanging form.
1156exprPlacement :: HsExpr GhcPs -> Placement
1222exprPlacement :: HsExpr GhcPs -> Placement
1157exprPlacement = \case
1223exprPlacement = \case
1158 -- Only hang lambdas with single line parameter lists
1224 -- Only hang lambdas with single line parameter lists
1159− HsLam NoExt mg -> case mg of
1225+ HsLam NoExtField mg -> case mg of
1160− MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
1226+ MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
1161 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
1227 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
1162 Hanging
1228 Hanging
1163 _ -> Normal
1229 _ -> Normal
1164− HsLamCase NoExt _ -> Hanging
1230+ HsLamCase NoExtField _ -> Hanging
1165− HsCase NoExt _ _ -> Hanging
1231+ HsCase NoExtField _ _ -> Hanging
1166− HsDo NoExt DoExpr _ -> Hanging
1232+ HsDo NoExtField DoExpr _ -> Hanging
1167− HsDo NoExt MDoExpr _ -> Hanging
1233+ HsDo NoExtField MDoExpr _ -> Hanging
1168− RecordCon NoExt _ _ -> Hanging
1234+ OpApp NoExtField _ op y ->
1169− -- If the rightmost expression in an operator chain is hanging, make the
1235+ case (fmap getOpNameStr . getOpName . unLoc) op of
1170− -- whole block hanging; so that we can use the common @f = foo $ do@
1171− -- style.
1172− OpApp NoExt _ _ y -> exprPlacement (unLoc y)
1236+ Just "$" -> exprPlacement (unLoc y)
1173− -- Same thing for function applications (usually with -XBlockArguments)
1237+ _ -> Normal
1174− HsApp NoExt _ y -> exprPlacement (unLoc y)
1238+ HsApp NoExtField _ y -> exprPlacement (unLoc y)
1175− HsProc NoExt (L s _) _ ->
1239+ HsProc NoExtField p _ ->
1176 -- Indentation breaks if pattern is longer than one line and left
1240 -- Indentation breaks if pattern is longer than one line and left
1177 -- hanging. Consequently, only apply hanging when it is safe.
1241 -- hanging. Consequently, only apply hanging when it is safe.
1178− if isOneLineSpan s
1242+ if isOneLineSpan (getLoc p)
1179 then Hanging
1243 then Hanging
1180 else Normal
1244 else Normal
1181 _ -> Normal
1245 _ -> Normal
@@ -1184,30 +1248,31 @@ withGuards :: [LGRHS GhcPs (Located body)] -> Bool
1184withGuards = any (checkOne . unLoc)
1248withGuards = any (checkOne . unLoc)
1185 where
1249 where
1186 checkOne :: GRHS GhcPs (Located body) -> Bool
1250 checkOne :: GRHS GhcPs (Located body) -> Bool
1187− checkOne (GRHS NoExt [] _) = False
1251+ checkOne (GRHS NoExtField [] _) = False
1188 checkOne _ = True
1252 checkOne _ = True
1189
1253
1190exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1254exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1191−exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
1255+exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
1192exprOpTree n = OpNode n
1256exprOpTree n = OpNode n
1193
1257
1194getOpName :: HsExpr GhcPs -> Maybe RdrName
1258getOpName :: HsExpr GhcPs -> Maybe RdrName
1195getOpName = \case
1259getOpName = \case
1196− HsVar NoExt (L _ a) -> Just a
1260+ HsVar NoExtField (L _ a) -> Just a
1197 _ -> Nothing
1261 _ -> Nothing
1198
1262
1263+getOpNameStr :: RdrName -> String
1264+getOpNameStr = occNameString . rdrNameOcc
1265+
1199p_exprOpTree ::
1266p_exprOpTree ::
1200− -- | Can use special handling of dollar?
1201− Bool ->
1202 -- | Bracket style to use
1267 -- | Bracket style to use
1203 BracketStyle ->
1268 BracketStyle ->
1204 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
1269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
1205 R ()
1270 R ()
1206−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1271+p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
1207−p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1272+p_exprOpTree s (OpBranch x op y) = do
1208− -- NOTE If the beginning of the first argument and the second argument
1273+ -- If the beginning of the first argument and the second argument are on
1209− -- are on the same line, and the second argument has a hanging form, use
1274+ -- the same line, and the second argument has a hanging form, use hanging
1210− -- hanging placement.
1275+ -- placement.
1211 let placement =
1276 let placement =
1212 if isOneLineSpan
1277 if isOneLineSpan
1213 (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
1278 (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
@@ -1215,8 +1280,10 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1215 OpNode (L _ n) -> exprPlacement n
1280 OpNode (L _ n) -> exprPlacement n
1216 _ -> Normal
1281 _ -> Normal
1217 else Normal
1282 else Normal
1283+ -- Distinguish holes used in infix notation.
1284+ -- eg. '1 _foo 2' and '1 `_foo` 2'
1218 opWrapper = case unLoc op of
1285 opWrapper = case unLoc op of
1219− EWildPat NoExt -> backticks
1286+ HsUnboundVar NoExtField _ -> backticks
1220 _ -> id
1287 _ -> id
1221 layout <- getLayout
1288 layout <- getLayout
1222 let ub = case layout of
1289 let ub = case layout of
@@ -1224,24 +1291,67 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1224 MultiLine -> case placement of
1291 MultiLine -> case placement of
1225 Hanging -> useBraces
1292 Hanging -> useBraces
1226 Normal -> dontUseBraces
1293 Normal -> dontUseBraces
1227− gotDollar = case getOpName (unLoc op) of
1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1228− Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
1295+ gotDollar = opNameStr == Just "$"
1296+ gotColon = opNameStr == Just ":"
1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
1298+ lhs =
1299+ switchLayout [opTreeLoc x] $
1300+ p_exprOpTree s x
1301+ p_op = located op (opWrapper . p_hsExpr)
1302+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
1303+ isSection = case (opTreeLoc x, getLoc op) of
1304+ (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
1305+ srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
1229 _ -> False
1306 _ -> False
1230− switchLayout [opTreeLoc x]
1307+ isDoBlock = \case
1231− $ ub
1308+ OpNode (L _ HsDo {}) -> True
1232− $ p_exprOpTree (not gotDollar) s x
1309+ _ -> False
1233− let p_op = located op (opWrapper . p_hsExpr)
1310+ useRecordDot' <- useRecordDot
1234− p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
1311+ if
1312+ | gotColon -> do
1313+ lhs
1314+ space
1315+ p_op
1316+ case placement of
1317+ Hanging -> do
1318+ space
1319+ p_y
1320+ Normal -> do
1321+ breakpoint
1322+ inciIf (isDoBlock y) p_y
1323+ | gotDollar
1235− if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
1324+ && isOneLineSpan (opTreeLoc x)
1236− then do
1325+ && placement == Normal -> do
1326+ useBraces lhs
1237− space
1327+ space
1238− p_op
1328+ p_op
1239− breakpoint
1329+ breakpoint
1240− inci p_y
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
1241− else placeHanging placement $ do
1338+ placeHanging placement $ do
1242− p_op
1339+ p_op
1243− space
1340+ space
1244− p_y
1341+ p_y
1342+
1343+-- | Return 'True' if given expression is a record-dot operator expression.
1344+isRecordDot ::
1345+ -- | Operator expression
1346+ HsExpr GhcPs ->
1347+ -- | Span of the expression on the right-hand side of the operator
1348+ SrcSpan ->
1349+ Bool
1350+isRecordDot op (RealSrcSpan ySpan) = case op of
1351+ HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1353+ _ -> False
1354+isRecordDot _ _ = False
1245
1355
1246-- | Get annotations for the enclosing element.
1356-- | Get annotations for the enclosing element.
1247getEnclosingAnns :: R [AnnKeywordId]
1357getEnclosingAnns :: R [AnnKeywordId]
src/Ormolu/Printer/Meat/Declaration/Value.hs-boot−4
@@ -11,11 +11,7 @@ import GHC
11import Ormolu.Printer.Combinators
11import Ormolu.Printer.Combinators
12
12
13p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
13p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
14−
15p_pat :: Pat GhcPs -> R ()
14p_pat :: Pat GhcPs -> R ()
16−
17p_hsExpr :: HsExpr GhcPs -> R ()
15p_hsExpr :: HsExpr GhcPs -> R ()
18−
19p_hsSplice :: HsSplice GhcPs -> R ()
16p_hsSplice :: HsSplice GhcPs -> R ()
20−
21p_stringLit :: String -> R ()
17p_stringLit :: String -> R ()
src/Ormolu/Printer/Meat/Declaration/Warning.hs+8−10
@@ -13,30 +13,28 @@ import Data.Text (Text)
13import GHC
13import GHC
14import Ormolu.Printer.Combinators
14import Ormolu.Printer.Combinators
15import Ormolu.Printer.Meat.Common
15import Ormolu.Printer.Meat.Common
16−import Ormolu.Utils
17
16
18p_warnDecls :: WarnDecls GhcPs -> R ()
17p_warnDecls :: WarnDecls GhcPs -> R ()
19−p_warnDecls (Warnings NoExt _ warnings) =
18+p_warnDecls (Warnings NoExtField _ warnings) =
20 traverse_ (located' p_warnDecl) warnings
19 traverse_ (located' p_warnDecl) warnings
21−p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"
20+p_warnDecls (XWarnDecls x) = noExtCon x
22
21
23p_warnDecl :: WarnDecl GhcPs -> R ()
22p_warnDecl :: WarnDecl GhcPs -> R ()
24−p_warnDecl (Warning NoExt functions warningTxt) =
23+p_warnDecl (Warning NoExtField functions warningTxt) =
25 p_topLevelWarning functions warningTxt
24 p_topLevelWarning functions warningTxt
26−p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"
25+p_warnDecl (XWarnDecl x) = noExtCon x
27
26
28p_moduleWarning :: WarningTxt -> R ()
27p_moduleWarning :: WarningTxt -> R ()
29p_moduleWarning wtxt = do
28p_moduleWarning wtxt = do
30 let (pragmaText, lits) = warningText wtxt
29 let (pragmaText, lits) = warningText wtxt
31− switchLayout (getLoc <$> lits) $ do
32− inci $ pragma pragmaText (inci $ p_lits lits)
30+ inci $ pragma pragmaText $ inci $ p_lits lits
33
31
34p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
32p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
35p_topLevelWarning fnames wtxt = do
33p_topLevelWarning fnames wtxt = do
36 let (pragmaText, lits) = warningText wtxt
34 let (pragmaText, lits) = warningText wtxt
37− switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $ do
35+ switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $
38 pragma pragmaText . inci $ do
36 pragma pragmaText . inci $ do
39− sitcc $ sep (comma >> breakpoint) p_rdrName fnames
37+ sep commaDel p_rdrName fnames
40 breakpoint
38 breakpoint
41 p_lits lits
39 p_lits lits
42
40
@@ -48,4 +46,4 @@ warningText = \case
48p_lits :: [Located StringLiteral] -> R ()
46p_lits :: [Located StringLiteral] -> R ()
49p_lits = \case
47p_lits = \case
50 [l] -> atom l
48 [l] -> atom l
51− ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls
49+ ls -> brackets N $ sep commaDel atom ls
src/Ormolu/Printer/Meat/ImportExport.hs+45−36
@@ -11,10 +11,9 @@ where
11
11
12import Control.Monad
12import Control.Monad
13import GHC
13import GHC
14−import HsImpExp (IE (..))
15import Ormolu.Printer.Combinators
14import Ormolu.Printer.Combinators
16import Ormolu.Printer.Meat.Common
15import Ormolu.Printer.Meat.Common
17−import Ormolu.Utils
16+import Ormolu.Utils (RelativePos (..), attachRelativePos)
18
17
19p_hsmodExports :: [LIE GhcPs] -> R ()
18p_hsmodExports :: [LIE GhcPs] -> R ()
20p_hsmodExports [] = do
19p_hsmodExports [] = do
@@ -22,19 +21,24 @@ p_hsmodExports [] = do
22 breakpoint'
21 breakpoint'
23 txt ")"
22 txt ")"
24p_hsmodExports xs =
23p_hsmodExports xs =
25− parens N . sitcc $ do
24+ parens N $ do
26 layout <- getLayout
25 layout <- getLayout
26+ sep
27+ breakpoint
27− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
28+ (\(p, l) -> sitcc (located l (p_lie layout p)))
29+ (attachRelativePos xs)
28
30
29−p_hsmodImport :: ImportDecl GhcPs -> R ()
31+p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
30−p_hsmodImport ImportDecl {..} = do
32+p_hsmodImport useQualifiedPost ImportDecl {..} = do
31 txt "import"
33 txt "import"
32 space
34 space
33 when ideclSource (txt "{-# SOURCE #-}")
35 when ideclSource (txt "{-# SOURCE #-}")
34 space
36 space
35 when ideclSafe (txt "safe")
37 when ideclSafe (txt "safe")
36 space
38 space
39+ when
40+ (isImportDeclQualified ideclQualified && not useQualifiedPost)
37− when ideclQualified (txt "qualified")
41+ (txt "qualified")
38 space
42 space
39 case ideclPkgQual of
43 case ideclPkgQual of
40 Nothing -> return ()
44 Nothing -> return ()
@@ -42,6 +46,9 @@ p_hsmodImport ImportDecl {..} = do
42 space
46 space
43 inci $ do
47 inci $ do
44 located ideclName atom
48 located ideclName atom
49+ when
50+ (isImportDeclQualified ideclQualified && useQualifiedPost)
51+ (space >> txt "qualified")
45 case ideclAs of
52 case ideclAs of
46 Nothing -> return ()
53 Nothing -> return ()
47 Just l -> do
54 Just l -> do
@@ -56,62 +63,64 @@ p_hsmodImport ImportDecl {..} = do
56 when hiding (txt "hiding")
63 when hiding (txt "hiding")
57 case ideclHiding of
64 case ideclHiding of
58 Nothing -> return ()
65 Nothing -> return ()
59− Just (_, (L _ xs)) -> do
66+ Just (_, L _ xs) -> do
60 breakpoint
67 breakpoint
61− parens N . sitcc $ do
68+ parens N $ do
62 layout <- getLayout
69 layout <- getLayout
70+ sep
71+ breakpoint
63− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
72+ (\(p, l) -> sitcc (located l (p_lie layout p)))
73+ (attachRelativePos xs)
64 newline
74 newline
65−p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"
75+p_hsmodImport _ (XImportDecl x) = noExtCon x
66
76
67−p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
77+p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
68−p_lie encLayout (i, totalItems) = \case
78+p_lie encLayout relativePos = \case
69− IEVar NoExt l1 -> do
79+ IEVar NoExtField l1 -> do
70 located l1 p_ieWrappedName
80 located l1 p_ieWrappedName
71 p_comma
81 p_comma
72− IEThingAbs NoExt l1 -> do
82+ IEThingAbs NoExtField l1 -> do
73 located l1 p_ieWrappedName
83 located l1 p_ieWrappedName
74 p_comma
84 p_comma
75− IEThingAll NoExt l1 -> do
85+ IEThingAll NoExtField l1 -> do
76 located l1 p_ieWrappedName
86 located l1 p_ieWrappedName
77 space
87 space
78 txt "(..)"
88 txt "(..)"
79 p_comma
89 p_comma
80− IEThingWith NoExt l1 w xs _ -> sitcc $ do
90+ IEThingWith NoExtField l1 w xs _ -> sitcc $ do
81 located l1 p_ieWrappedName
91 located l1 p_ieWrappedName
82 breakpoint
92 breakpoint
83 inci $ do
93 inci $ do
84 let names :: [R ()]
94 let names :: [R ()]
85 names = located' p_ieWrappedName <$> xs
95 names = located' p_ieWrappedName <$> xs
86− parens N . sitcc
96+ parens N . sep commaDel sitcc $
87− $ sep (comma >> breakpoint) sitcc
88− $ case w of
97+ case w of
89 NoIEWildcard -> names
98 NoIEWildcard -> names
90 IEWildcard n ->
99 IEWildcard n ->
91 let (before, after) = splitAt n names
100 let (before, after) = splitAt n names
92 in before ++ [txt ".."] ++ after
101 in before ++ [txt ".."] ++ after
93 p_comma
102 p_comma
94− IEModuleContents NoExt l1 -> do
103+ IEModuleContents NoExtField l1 -> do
95 located l1 p_hsmodName
104 located l1 p_hsmodName
96 p_comma
105 p_comma
97− IEGroup NoExt n str -> do
106+ IEGroup NoExtField n str -> do
107+ case relativePos of
108+ SinglePos -> return ()
109+ FirstPos -> return ()
110+ MiddlePos -> newline
98− unless (i == 0) newline
111+ LastPos -> newline
99 p_hsDocString (Asterisk n) False (noLoc str)
112 p_hsDocString (Asterisk n) False (noLoc str)
100− IEDoc NoExt str ->
113+ IEDoc NoExtField str ->
101 p_hsDocString Pipe False (noLoc str)
114 p_hsDocString Pipe False (noLoc str)
102− IEDocNamed NoExt str -> p_hsDocName str
115+ IEDocNamed NoExtField str -> p_hsDocName str
103− XIE NoExt -> notImplemented "XIE"
116+ XIE x -> noExtCon x
104 where
117 where
105 p_comma =
118 p_comma =
106 case encLayout of
119 case encLayout of
107− SingleLine -> unless (i + 1 == totalItems) comma
120+ SingleLine ->
121+ case relativePos of
122+ SinglePos -> return ()
123+ FirstPos -> comma
124+ MiddlePos -> comma
125+ LastPos -> return ()
108 MultiLine -> comma
126 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+38−17
@@ -9,9 +9,12 @@ module Ormolu.Printer.Meat.Module
9where
9where
10
10
11import Control.Monad
11import Control.Monad
12+import qualified Data.Text as T
12import GHC
13import GHC
13−import Ormolu.Imports
14+import Ormolu.Imports (normalizeImports)
15+import Ormolu.Parser.CommentStream
14import Ormolu.Parser.Pragma
16import Ormolu.Parser.Pragma
17+import Ormolu.Parser.Shebang
15import Ormolu.Printer.Combinators
18import Ormolu.Printer.Combinators
16import Ormolu.Printer.Comments
19import Ormolu.Printer.Comments
17import Ormolu.Printer.Meat.Common
20import Ormolu.Printer.Meat.Common
@@ -20,35 +23,53 @@ import Ormolu.Printer.Meat.Declaration.Warning
20import Ormolu.Printer.Meat.ImportExport
23import Ormolu.Printer.Meat.ImportExport
21import Ormolu.Printer.Meat.Pragma
24import Ormolu.Printer.Meat.Pragma
22
25
26+-- | Render a module.
23−p_hsModule :: [Pragma] -> ParsedSource -> R ()
27+p_hsModule ::
28+ -- | Stack header
29+ Maybe (RealLocated Comment) ->
30+ -- | Shebangs
31+ [Shebang] ->
32+ -- | Pragmas and the associated comments
33+ [([RealLocated Comment], Pragma)] ->
34+ -- | Whether to use postfix qualified imports
35+ Bool ->
36+ -- | AST to print
37+ HsModule GhcPs ->
38+ R ()
24−p_hsModule pragmas (L moduleSpan HsModule {..}) = do
39+p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do
25− -- NOTE If span of exports in multiline, the whole thing is multiline.
40+ let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
26− -- This is especially important because span of module itself always seems
27− -- to have length zero, so it's not reliable for layout selection.
28− let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
41+ exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
29− deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
30− spans' = exportSpans ++ deprecSpan ++ [moduleSpan]
31− switchLayout spans' $ do
42+ switchLayout (deprecSpan <> exportSpans) $ do
43+ forM_ shebangs $ \(Shebang x) ->
44+ located x $ \shebang -> do
45+ txt (T.pack shebang)
46+ newline
47+ forM_ mstackHeader $ \(L spn comment) -> do
48+ spitCommentNow spn comment
49+ newline
50+ newline
32 p_pragmas pragmas
51 p_pragmas pragmas
33 newline
52 newline
34− forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
35 case hsmodName of
53 case hsmodName of
36 Nothing -> return ()
54 Nothing -> return ()
37 Just hsmodName' -> do
55 Just hsmodName' -> do
38− located hsmodName' p_hsmodName
56+ located hsmodName' $ \name -> do
57+ forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
58+ p_hsmodName name
59+ breakpoint
39 forM_ hsmodDeprecMessage $ \w -> do
60 forM_ hsmodDeprecMessage $ \w -> do
40− breakpoint
41 located' p_moduleWarning w
61 located' p_moduleWarning w
62+ breakpoint
42 case hsmodExports of
63 case hsmodExports of
43 Nothing -> return ()
64 Nothing -> return ()
44− Just hsmodExports' -> do
65+ Just l -> do
66+ located l $ \exports -> do
67+ inci (p_hsmodExports exports)
45 breakpoint
68 breakpoint
46− inci (p_hsmodExports (unLoc hsmodExports'))
47− breakpoint
48 txt "where"
69 txt "where"
49 newline
70 newline
50 newline
71 newline
51− forM_ (sortImports hsmodImports) (located' p_hsmodImport)
72+ forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
52 newline
73 newline
53 switchLayout (getLoc <$> hsmodDecls) $ do
74 switchLayout (getLoc <$> hsmodDecls) $ do
54 p_hsDecls Free hsmodDecls
75 p_hsDecls Free hsmodDecls
src/Ormolu/Printer/Meat/Pragma.hs+67−13
@@ -8,30 +8,84 @@ module Ormolu.Printer.Meat.Pragma
8 )
8 )
9where
9where
10
10
11+import Control.Monad
12+import Data.Char (isUpper)
11−import qualified Data.Set as S
13+import qualified Data.List as L
14+import Data.Maybe (listToMaybe)
12import qualified Data.Text as T
15import qualified Data.Text as T
16+import Ormolu.Parser.CommentStream
13import Ormolu.Parser.Pragma (Pragma (..))
17import Ormolu.Parser.Pragma (Pragma (..))
14import Ormolu.Printer.Combinators
18import Ormolu.Printer.Combinators
19+import Ormolu.Printer.Comments
20+import SrcLoc
15
21
22+-- | Pragma classification.
23+data PragmaTy
24+ = Language LanguagePragmaClass
25+ | OptionsGHC
16−data PragmaTy = Language | OptionsGHC | OptionsHaddock
26+ | OptionsHaddock
17 deriving (Eq, Ord)
27 deriving (Eq, Ord)
18
28
29+-- | Language pragma classification.
30+--
31+-- The order in which language pragmas are put in the input sometimes
32+-- matters. This is because some language extensions can enable other
33+-- extensions, yet the extensions coming later in the list have the ability
34+-- to change it. So here we classify all extensions by assigning one of the
35+-- four groups to them. Then we only sort inside of the groups.
36+--
37+-- 'Ord' instance of this data type is what affects the sorting.
38+--
39+-- See also: <https://github.com/tweag/ormolu/issues/404>
40+data LanguagePragmaClass
41+ = -- | All other extensions
42+ Normal
43+ | -- | Extensions starting with "No"
44+ Disabling
45+ | -- | Extensions that should go after everything else
46+ Final
47+ deriving (Eq, Ord)
48+
49+-- | Print a collection of 'Pragma's with their associated comments.
19−p_pragmas :: [Pragma] -> R ()
50+p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()
20−p_pragmas ps =
51+p_pragmas ps = do
21− let prepare = concatMap $ \case
52+ let prepare = L.sortOn snd . L.nub . concatMap analyze
53+ analyze = \case
22− PragmaLanguage xs -> (Language,) <$> xs
54+ (cs, PragmaLanguage xs) ->
55+ let f x = (cs, (Language (classifyLanguagePragma x), x))
56+ in f <$> xs
23− PragmaOptionsGHC x -> [(OptionsGHC, x)]
57+ (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]
24− PragmaOptionsHaddock x -> [(OptionsHaddock, x)]
58+ (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]
25− in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
59+ forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->
60+ p_pragma cs pragmaTy x
26
61
27−p_pragma :: PragmaTy -> String -> R ()
62+p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()
28−p_pragma ty c = do
63+p_pragma comments ty x = do
64+ forM_ comments $ \(L l comment) -> do
65+ spitCommentNow l comment
66+ newline
29 txt "{-# "
67 txt "{-# "
30 txt $ case ty of
68 txt $ case ty of
31− Language -> "LANGUAGE"
69+ Language _ -> "LANGUAGE"
32 OptionsGHC -> "OPTIONS_GHC"
70 OptionsGHC -> "OPTIONS_GHC"
33 OptionsHaddock -> "OPTIONS_HADDOCK"
71 OptionsHaddock -> "OPTIONS_HADDOCK"
34 space
72 space
35− txt (T.pack c)
73+ txt (T.pack x)
36 txt " #-}"
74 txt " #-}"
37 newline
75 newline
76+
77+-- | Classify a 'LanguagePragma'.
78+classifyLanguagePragma :: String -> LanguagePragmaClass
79+classifyLanguagePragma = \case
80+ "ImplicitPrelude" -> Final
81+ "CUSKs" -> Final
82+ str ->
83+ case splitAt 2 str of
84+ ("No", rest) ->
85+ case listToMaybe rest of
86+ Nothing -> Normal
87+ Just x ->
88+ if isUpper x
89+ then Disabling
90+ else Normal
91+ _ -> Normal
src/Ormolu/Printer/Meat/Type.hs+123−81
@@ -5,16 +5,18 @@
5-- | Rendering of types.
5-- | Rendering of types.
6module Ormolu.Printer.Meat.Type
6module Ormolu.Printer.Meat.Type
7 ( p_hsType,
7 ( p_hsType,
8+ p_hsTypePostDoc,
8 hasDocStrings,
9 hasDocStrings,
9 p_hsContext,
10 p_hsContext,
10 p_hsTyVarBndr,
11 p_hsTyVarBndr,
12+ p_forallBndrs,
11 p_conDeclFields,
13 p_conDeclFields,
12 tyVarsToTypes,
14 tyVarsToTypes,
13 )
15 )
14where
16where
15
17
16−import BasicTypes
18+import Data.Data (Data)
17−import GHC
19+import GHC hiding (isPromoted)
18import Ormolu.Printer.Combinators
20import Ormolu.Printer.Combinators
19import Ormolu.Printer.Meat.Common
21import Ormolu.Printer.Meat.Common
20import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
22import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
@@ -22,17 +24,23 @@ import Ormolu.Printer.Operators
22import Ormolu.Utils
24import Ormolu.Utils
23
25
24p_hsType :: HsType GhcPs -> R ()
26p_hsType :: HsType GhcPs -> R ()
25−p_hsType t = p_hsType' (hasDocStrings t) t
27+p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t
26−
28+
29+p_hsTypePostDoc :: HsType GhcPs -> R ()
30+p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t
31+
32+-- | How to render Haddocks associated with a type.
33+data TypeDocStyle
34+ = PipeStyle
35+ | CaretStyle
36+
27−p_hsType' :: Bool -> HsType GhcPs -> R ()
37+p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()
28−p_hsType' multilineArgs = \case
38+p_hsType' multilineArgs docStyle = \case
29− HsForAllTy NoExt bndrs t -> do
39+ HsForAllTy NoExtField visibility bndrs t -> do
30− txt "forall "
31− sep space (located' p_hsTyVarBndr) bndrs
40+ p_forallBndrs visibility p_hsTyVarBndr bndrs
32− txt "."
33 interArgBreak
41 interArgBreak
34− p_hsType' multilineArgs (unLoc t)
42+ p_hsTypeR (unLoc t)
35− HsQualTy NoExt qs t -> do
43+ HsQualTy NoExtField qs t -> do
36 located qs p_hsContext
44 located qs p_hsContext
37 space
45 space
38 txt "=>"
46 txt "=>"
@@ -41,20 +49,39 @@ p_hsType' multilineArgs = \case
41 HsQualTy {} -> p_hsTypeR (unLoc t)
49 HsQualTy {} -> p_hsTypeR (unLoc t)
42 HsFunTy {} -> p_hsTypeR (unLoc t)
50 HsFunTy {} -> p_hsTypeR (unLoc t)
43 _ -> located t p_hsTypeR
51 _ -> located t p_hsTypeR
44− HsTyVar NoExt p n -> do
52+ HsTyVar NoExtField p n -> do
45 case p of
53 case p of
46− Promoted -> do
54+ IsPromoted -> do
47 txt "'"
55 txt "'"
48 case showOutputable (unLoc n) of
56 case showOutputable (unLoc n) of
49 _ : '\'' : _ -> space
57 _ : '\'' : _ -> space
50 _ -> return ()
58 _ -> return ()
51 NotPromoted -> return ()
59 NotPromoted -> return ()
52 p_rdrName n
60 p_rdrName n
53− HsAppTy NoExt f x -> sitcc $ do
61+ HsAppTy NoExtField f x -> do
62+ let -- In order to format type applications with multiple parameters
63+ -- nicer, traverse the AST to gather the function and all the
64+ -- parameters together.
65+ gatherArgs f' knownArgs =
66+ case f' of
67+ L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)
68+ _ -> (f', knownArgs)
69+ (func, args) = gatherArgs f [x]
70+ switchLayout (getLoc f : fmap getLoc args) . sitcc $ do
71+ located func p_hsType
72+ breakpoint
73+ inci $
74+ sep breakpoint (located' p_hsType) args
75+ HsAppKindTy _ ty kd -> sitcc $ do
76+ -- 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
78+ -- type and the kind.
54− located f p_hsType
79+ located ty p_hsType
55 breakpoint
80 breakpoint
81+ inci $ do
82+ txt "@"
56− inci (located x p_hsType)
83+ located kd p_hsType
57− HsFunTy NoExt x y@(L _ y') -> do
84+ HsFunTy NoExtField x y@(L _ y') -> do
58 located x p_hsType
85 located x p_hsType
59 space
86 space
60 txt "->"
87 txt "->"
@@ -62,51 +89,49 @@ p_hsType' multilineArgs = \case
62 case y' of
89 case y' of
63 HsFunTy {} -> p_hsTypeR y'
90 HsFunTy {} -> p_hsTypeR y'
64 _ -> located y p_hsTypeR
91 _ -> located y p_hsTypeR
65− HsListTy NoExt t ->
92+ HsListTy NoExtField t ->
66 located t (brackets N . p_hsType)
93 located t (brackets N . p_hsType)
67− HsTupleTy NoExt tsort xs ->
94+ HsTupleTy NoExtField tsort xs ->
68 let parens' =
95 let parens' =
69 case tsort of
96 case tsort of
70 HsUnboxedTuple -> parensHash N
97 HsUnboxedTuple -> parensHash N
71 HsBoxedTuple -> parens N
98 HsBoxedTuple -> parens N
72 HsConstraintTuple -> parens N
99 HsConstraintTuple -> parens N
73 HsBoxedOrConstraintTuple -> parens N
100 HsBoxedOrConstraintTuple -> parens N
74− in parens' . sitcc $
75− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
101+ in parens' $ sep commaDel (sitcc . located' p_hsType) xs
76− HsSumTy NoExt xs ->
102+ HsSumTy NoExtField xs ->
77− parensHash N . sitcc $
103+ parensHash N $
78 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
104 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
79− HsOpTy NoExt x op y -> sitcc $ do
105+ HsOpTy NoExtField x op y ->
106+ sitcc $
80− let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
107+ let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
81− in p_tyOpTree (reassociateOpTree Just opTree)
108+ in p_tyOpTree (reassociateOpTree Just opTree)
82− HsParTy NoExt (L _ t@HsKindSig {}) ->
109+ HsParTy NoExtField t ->
83− -- NOTE Kind signatures already put parentheses around in all cases, so
84− -- skip this layer of parentheses. The reason for this behavior is that
85− -- parentheses are not always encoded with 'HsParTy', but seem to be
86− -- always necessary when we have kind signatures in place.
87− p_hsType t
88− HsParTy NoExt t ->
89 parens N (located t p_hsType)
110 parens N (located t p_hsType)
90− HsIParamTy NoExt n t -> sitcc $ do
111+ HsIParamTy NoExtField n t -> sitcc $ do
91 located n atom
112 located n atom
92 space
113 space
93 txt "::"
114 txt "::"
94 breakpoint
115 breakpoint
95 inci (located t p_hsType)
116 inci (located t p_hsType)
96− HsStarTy NoExt _ -> txt "*"
117+ HsStarTy NoExtField _ -> txt "*"
97− HsKindSig NoExt t k ->
118+ HsKindSig NoExtField t k -> sitcc $ do
98− -- NOTE Also see the comment for 'HsParTy'.
99− parens N . sitcc $ do
100− located t p_hsType
101− space -- FIXME
102− txt "::"
103− space
104− inci (located k p_hsType)
105− HsSpliceTy NoExt splice -> p_hsSplice splice
106− HsDocTy NoExt t str -> do
107− p_hsDocString Pipe True str
108 located t p_hsType
119 located t p_hsType
120+ space
121+ txt "::"
122+ breakpoint
123+ inci (located k p_hsType)
124+ HsSpliceTy NoExtField splice -> p_hsSplice splice
125+ HsDocTy NoExtField t str ->
126+ case docStyle of
127+ PipeStyle -> do
128+ p_hsDocString Pipe True str
129+ located t p_hsType
130+ CaretStyle -> do
131+ located t p_hsType
132+ newline
133+ p_hsDocString Caret False str
109− HsBangTy NoExt (HsSrcBang _ u s) t -> do
134+ HsBangTy NoExtField (HsSrcBang _ u s) t -> do
110 case u of
135 case u of
111 SrcUnpack -> txt "{-# UNPACK #-}" >> space
136 SrcUnpack -> txt "{-# UNPACK #-}" >> space
112 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
137 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
@@ -116,49 +141,49 @@ p_hsType' multilineArgs = \case
116 SrcStrict -> txt "!"
141 SrcStrict -> txt "!"
117 NoSrcStrict -> return ()
142 NoSrcStrict -> return ()
118 located t p_hsType
143 located t p_hsType
119− HsRecTy NoExt fields ->
144+ HsRecTy NoExtField fields ->
120 p_conDeclFields fields
145 p_conDeclFields fields
121− HsExplicitListTy NoExt p xs -> do
146+ HsExplicitListTy NoExtField p xs -> do
122 case p of
147 case p of
123− Promoted -> txt "'"
148+ IsPromoted -> txt "'"
124 NotPromoted -> return ()
149 NotPromoted -> return ()
125 brackets N $ do
150 brackets N $ do
126 -- If both this list itself and the first element is promoted,
151 -- If both this list itself and the first element is promoted,
127 -- we need to put a space in between or it fails to parse.
152 -- we need to put a space in between or it fails to parse.
128 case (p, xs) of
153 case (p, xs) of
129− (Promoted, ((L _ t) : _)) | isPromoted t -> space
154+ (IsPromoted, L _ t : _) | isPromoted t -> space
130 _ -> return ()
155 _ -> return ()
131− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
156+ sep commaDel (sitcc . located' p_hsType) xs
132− HsExplicitTupleTy NoExt xs -> do
157+ HsExplicitTupleTy NoExtField xs -> do
133 txt "'"
158 txt "'"
134 parens N $ do
159 parens N $ do
135 case xs of
160 case xs of
136− ((L _ t) : _) | isPromoted t -> space
161+ L _ t : _ | isPromoted t -> space
137 _ -> return ()
162 _ -> return ()
138− sep (comma >> breakpoint) (located' p_hsType) xs
163+ sep commaDel (located' p_hsType) xs
139− HsTyLit NoExt t ->
164+ HsTyLit NoExtField t ->
140 case t of
165 case t of
141 HsStrTy (SourceText s) _ -> p_stringLit s
166 HsStrTy (SourceText s) _ -> p_stringLit s
142 a -> atom a
167 a -> atom a
143− HsWildCardTy NoExt -> txt "_"
168+ HsWildCardTy NoExtField -> txt "_"
144 XHsType (NHsCoreTy t) -> atom t
169 XHsType (NHsCoreTy t) -> atom t
145 where
170 where
146 isPromoted = \case
171 isPromoted = \case
147− HsTyVar _ Promoted _ -> True
172+ HsTyVar _ IsPromoted _ -> True
173+ HsExplicitTupleTy {} -> True
148− HsExplicitListTy _ _ _ -> True
174+ HsExplicitListTy {} -> True
149− HsExplicitTupleTy _ _ -> True
150 _ -> False
175 _ -> False
151 interArgBreak =
176 interArgBreak =
152 if multilineArgs
177 if multilineArgs
153 then newline
178 then newline
154 else breakpoint
179 else breakpoint
155− p_hsTypeR = p_hsType' multilineArgs
180+ p_hsTypeR = p_hsType' multilineArgs docStyle
156
181
157-- | Return 'True' if at least one argument in 'HsType' has a doc string
182-- | Return 'True' if at least one argument in 'HsType' has a doc string
158-- attached to it.
183-- attached to it.
159hasDocStrings :: HsType GhcPs -> Bool
184hasDocStrings :: HsType GhcPs -> Bool
160hasDocStrings = \case
185hasDocStrings = \case
161− HsDocTy _ _ _ -> True
186+ HsDocTy {} -> True
162 HsFunTy _ (L _ x) (L _ y) -> hasDocStrings x || hasDocStrings y
187 HsFunTy _ (L _ x) (L _ y) -> hasDocStrings x || hasDocStrings y
163 _ -> False
188 _ -> False
164
189
@@ -166,49 +191,61 @@ p_hsContext :: HsContext GhcPs -> R ()
166p_hsContext = \case
191p_hsContext = \case
167 [] -> txt "()"
192 [] -> txt "()"
168 [x] -> located x p_hsType
193 [x] -> located x p_hsType
169− xs ->
170− parens N . sitcc $
171− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
194+ xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs
172
195
173p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
196p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
174p_hsTyVarBndr = \case
197p_hsTyVarBndr = \case
175− UserTyVar NoExt x ->
198+ UserTyVar NoExtField x ->
176 p_rdrName x
199 p_rdrName x
177− KindedTyVar NoExt l k -> parens N $ do
200+ KindedTyVar NoExtField l k -> parens N $ do
178 located l atom
201 located l atom
179 space
202 space
180 txt "::"
203 txt "::"
181 breakpoint
204 breakpoint
182 inci (located k p_hsType)
205 inci (located k p_hsType)
183− XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
206+ XTyVarBndr x -> noExtCon x
207+
208+-- | Render several @forall@-ed variables.
209+p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
210+p_forallBndrs ForallInvis _ [] = txt "forall."
211+p_forallBndrs ForallVis _ [] = txt "forall ->"
212+p_forallBndrs vis p tyvars =
213+ switchLayout (getLoc <$> tyvars) $ do
214+ txt "forall"
215+ breakpoint
216+ inci $ do
217+ sitcc $ sep breakpoint (sitcc . located' p) tyvars
218+ case vis of
219+ ForallInvis -> txt "."
220+ ForallVis -> space >> txt "->"
184
221
185p_conDeclFields :: [LConDeclField GhcPs] -> R ()
222p_conDeclFields :: [LConDeclField GhcPs] -> R ()
186p_conDeclFields xs =
223p_conDeclFields xs =
187− braces N . sitcc $
188− sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
224+ braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
189
225
190p_conDeclField :: ConDeclField GhcPs -> R ()
226p_conDeclField :: ConDeclField GhcPs -> R ()
191p_conDeclField ConDeclField {..} = do
227p_conDeclField ConDeclField {..} = do
192 mapM_ (p_hsDocString Pipe True) cd_fld_doc
228 mapM_ (p_hsDocString Pipe True) cd_fld_doc
193 sitcc $
229 sitcc $
194− sep (comma >> breakpoint)
230+ sep
231+ commaDel
195 (located' (p_rdrName . rdrNameFieldOcc))
232 (located' (p_rdrName . rdrNameFieldOcc))
196 cd_fld_names
233 cd_fld_names
197 space
234 space
198 txt "::"
235 txt "::"
199 breakpoint
236 breakpoint
200 sitcc . inci $ p_hsType (unLoc cd_fld_type)
237 sitcc . inci $ p_hsType (unLoc cd_fld_type)
201−p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"
238+p_conDeclField (XConDeclField x) = noExtCon x
202
239
203tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
240tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
204−tyOpTree (L _ (HsOpTy NoExt l op r)) =
241+tyOpTree (L _ (HsOpTy NoExtField l op r)) =
205 OpBranch (tyOpTree l) op (tyOpTree r)
242 OpBranch (tyOpTree l) op (tyOpTree r)
206tyOpTree n = OpNode n
243tyOpTree n = OpNode n
207
244
208p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R ()
245p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R ()
209p_tyOpTree (OpNode n) = located n p_hsType
246p_tyOpTree (OpNode n) = located n p_hsType
210p_tyOpTree (OpBranch l op r) = do
247p_tyOpTree (OpBranch l op r) = do
211− switchLayout [opTreeLoc l] $ do
248+ switchLayout [opTreeLoc l] $
212 p_tyOpTree l
249 p_tyOpTree l
213 breakpoint
250 breakpoint
214 inci . switchLayout [opTreeLoc r] $ do
251 inci . switchLayout [opTreeLoc r] $ do
@@ -222,12 +259,17 @@ p_tyOpTree (OpBranch l op r) = do
222tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
259tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
223tyVarsToTypes = \case
260tyVarsToTypes = \case
224 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
261 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
225− XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
262+ XLHsQTyVars x -> noExtCon x
226
263
227tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
264tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
228tyVarToType = \case
265tyVarToType = \case
229− UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
266+ UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
230− KindedTyVar NoExt tvar kind ->
267+ KindedTyVar NoExtField tvar kind ->
231− HsParTy NoExt $ noLoc $
268+ -- Note: we always add parentheses because for whatever reason GHC does
269+ -- not use HsParTy for left-hand sides of declarations. Please see
270+ -- <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
272+ -- declarations.
273+ HsParTy NoExtField . noLoc $
232− HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
274+ HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
233− XTyVarBndr {} -> notImplemented "XTyVarBndr"
275+ XTyVarBndr x -> noExtCon x
src/Ormolu/Printer/Operators.hs+57−62
@@ -10,14 +10,14 @@ module Ormolu.Printer.Operators
10 )
10 )
11where
11where
12
12
13−import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)
14import Data.Function (on)
13import Data.Function (on)
15−import Data.List
14+import qualified Data.List as L
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
16−import Data.Maybe (fromMaybe)
17+import Data.Maybe (fromMaybe, mapMaybe)
17import GHC
18import GHC
18−import OccName (mkVarOcc)
19+import OccName (occNameString)
19−import RdrName (mkRdrUnqual)
20+import Ormolu.Utils (unSrcSpan)
20−import SrcLoc (combineSrcSpans)
21
21
22-- | Intermediate representation of operator trees. It has two type
22-- | Intermediate representation of operator trees. It has two type
23-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
23-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
@@ -57,7 +57,7 @@ reassociateOpTree getOpName opTree =
57reassociateOpTreeWith ::
57reassociateOpTreeWith ::
58 forall ty op.
58 forall ty op.
59 -- | Fixity map for operators
59 -- | Fixity map for operators
60− [(RdrName, Fixity)] ->
60+ Map String Fixity ->
61 -- | How to get the name of an operator
61 -- | How to get the name of an operator
62 (op -> Maybe RdrName) ->
62 (op -> Maybe RdrName) ->
63 -- | Original 'OpTree'
63 -- | Original 'OpTree'
@@ -68,13 +68,13 @@ reassociateOpTreeWith fixityMap getOpName = go
68 where
68 where
69 fixityOf :: op -> Fixity
69 fixityOf :: op -> Fixity
70 fixityOf op = fromMaybe defaultFixity $ do
70 fixityOf op = fromMaybe defaultFixity $ do
71− opName <- getOpName op
71+ s <- occNameString . rdrNameOcc <$> getOpName op
72− lookup opName fixityMap
72+ M.lookup s fixityMap
73 -- Here, left branch is already associated and the root alongside with
73 -- Here, left branch is already associated and the root alongside with
74 -- the right branch is right-associated. This function picks up one item
74 -- the right branch is right-associated. This function picks up one item
75 -- from the right and inserts it correctly to the left.
75 -- from the right and inserts it correctly to the left.
76 --
76 --
77− -- Also, we are using the 'compareFixity' function which returns if the
77+ -- Also, we are using the 'compareFixity' function which tells if the
78 -- expression should associate to right.
78 -- expression should associate to right.
79 go :: OpTree ty op -> OpTree ty op
79 go :: OpTree ty op -> OpTree ty op
80 -- base cases
80 -- base cases
@@ -94,6 +94,16 @@ reassociateOpTreeWith fixityMap getOpName = go
94 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
94 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
95 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
95 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
96
96
97+-- | A score assigned to an operator.
98+data Score
99+ = -- | The operator was placed at the beginning of a line
100+ AtBeginning Int
101+ | -- | The operator was placed at the end of a line
102+ AtEnd
103+ | -- | The operator was placed in between arguments on a single line
104+ InBetween
105+ deriving (Eq, Ord)
106+
97-- | Build a map of inferred 'Fixity's from an 'OpTree'.
107-- | Build a map of inferred 'Fixity's from an 'OpTree'.
98buildFixityMap ::
108buildFixityMap ::
99 forall ty op.
109 forall ty op.
@@ -102,23 +112,26 @@ buildFixityMap ::
102 -- | Operator tree
112 -- | Operator tree
103 OpTree (Located ty) (Located op) ->
113 OpTree (Located ty) (Located op) ->
104 -- | Fixity map
114 -- | Fixity map
105− [(RdrName, Fixity)]
115+ Map String Fixity
106buildFixityMap getOpName opTree =
116buildFixityMap getOpName opTree =
117+ addOverrides
118+ . M.fromList
107− concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
119+ . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
108− . zip [0 ..]
120+ . zip [2 ..]
109− . groupBy (doubleWithinEps 0.00001 `on` snd)
121+ . L.groupBy ((==) `on` snd)
110− . (overrides ++)
122+ . selectScores
111− . avgScores
112 $ score opTree
123 $ score opTree
113 where
124 where
114− -- Add a special case for ($), since it is pretty unlikely for someone
125+ addOverrides :: Map String Fixity -> Map String Fixity
115− -- to override it.
126+ addOverrides m =
116− overrides :: [(RdrName, Double)]
127+ M.fromList
117− overrides =
128+ [ ("$", fixity 0 InfixR),
118− [ (mkRdrUnqual $ mkVarOcc "$", -1)
129+ (":", fixity 1 InfixR),
119− ]
130+ (".", fixity 100 InfixL)
120− -- Assign scores to operators based on their location in the source.
131+ ]
132+ `M.union` m
133+ fixity = Fixity NoSourceText
121− score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]
134+ score :: OpTree (Located ty) (Located op) -> [(String, Score)]
122 score (OpNode _) = []
135 score (OpNode _) = []
123 score (OpBranch l o r) = fromMaybe (score r) $ do
136 score (OpBranch l o r) = fromMaybe (score r) $ do
124 -- If we fail to get any of these, 'defaultFixity' will be used by
137 -- If we fail to get any of these, 'defaultFixity' will be used by
@@ -128,39 +141,27 @@ buildFixityMap getOpName opTree =
128 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
141 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
129 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
142 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
130 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
143 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
131− opName <- getOpName (unLoc o)
144+ opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
132− let s =
145+ let s
133− if le < ob
146+ | le < ob = AtBeginning oc
134− then-- if the operator is in the beginning of a line, assign
135− -- a score relative to its column within range [0, 1).
136− fromIntegral oc / fromIntegral (maxCol + 1)
137− else-- if the operator is in the end of the line, assign the
138− -- score 1.
139−
140− if oe < rb
147+ | oe < rb = AtEnd
141− then 1
148+ | otherwise = InBetween
142− else 2 -- otherwise, assign a high score.
143 return $ (opName, s) : score r
149 return $ (opName, s) : score r
144− avgScores :: [(RdrName, Double)] -> [(RdrName, Double)]
150+ selectScores :: [(String, Score)] -> [(String, Score)]
145− avgScores =
151+ selectScores =
146− sortOn snd
152+ L.sortOn snd
153+ . mapMaybe
154+ ( \case
155+ [] -> Nothing
147− . map (\xs@((n, _) : _) -> (n, avg $ map snd xs))
156+ xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)
157+ )
148− . groupBy ((==) `on` fst)
158+ . L.groupBy ((==) `on` fst)
149− . sort
159+ . L.sort
150− avg :: [Double] -> Double
160+ selectScore :: [Score] -> Score
151− avg i = sum i / fromIntegral (length i)
161+ selectScore xs =
152− -- The start column of the rightmost operator.
162+ case filter (/= InBetween) xs of
153− maxCol = go opTree
163+ [] -> InBetween
154− where
155− go (OpNode (L _ _)) = 0
156− go (OpBranch l (L o _) r) =
157− maximum
164+ xs' -> maximum xs'
158− [ go l,
159− maybe 0 srcSpanStartCol (unSrcSpan o),
160− go r
161− ]
162− unSrcSpan (RealSrcSpan r) = Just r
163− unSrcSpan (UnhelpfulSpan _) = Nothing
164
165
165----------------------------------------------------------------------------
166----------------------------------------------------------------------------
166-- Helpers
167-- Helpers
@@ -174,9 +175,3 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =
174 OpBranch (OpNode l) lop (normalizeOpTree r)
175 OpBranch (OpNode l) lop (normalizeOpTree r)
175normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
176normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
176 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
177 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
177−
178−fixity :: Int -> FixityDirection -> Fixity
179−fixity = Fixity NoSourceText
180−
181−doubleWithinEps :: Double -> Double -> Double -> Bool
182−doubleWithinEps eps a b = abs (a - b) < eps
src/Ormolu/Printer/SpanStream.hs+1−1
@@ -36,7 +36,7 @@ mkSpanStream a =
36 $ everything mappend (const mempty `ext2Q` queryLocated) a
36 $ everything mappend (const mempty `ext2Q` queryLocated) a
37 where
37 where
38 queryLocated ::
38 queryLocated ::
39− (Data e0, Data e1) =>
39+ (Data e0) =>
40 GenLocated e0 e1 ->
40 GenLocated e0 e1 ->
41 DList RealSrcSpan
41 DList RealSrcSpan
42 queryLocated (L mspn _) =
42 queryLocated (L mspn _) =
src/Ormolu/Processing/Common.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- | Common definitions for pre- and post- processing.
4+module Ormolu.Processing.Common
5+ ( OrmoluState (..),
6+ startDisabling,
7+ endDisabling,
8+ )
9+where
10+
11+import Data.String (IsString (..))
12+
13+-- | Ormolu state.
14+data OrmoluState
15+ = -- | Enabled
16+ OrmoluEnabled
17+ | -- | Disabled
18+ OrmoluDisabled
19+ deriving (Eq, Show)
20+
21+-- | Marker for the beginning of the region where Ormolu should be disabled.
22+startDisabling :: IsString s => s
23+startDisabling = "{- ORMOLU_DISABLE_START"
24+
25+-- | Marker for the end of the region where Ormolu should be disabled.
26+endDisabling :: IsString s => s
27+endDisabling = "ORMOLU_DISABLE_END -}"
src/Ormolu/Processing/Cpp.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- | Support for CPP.
4+module Ormolu.Processing.Cpp
5+ ( State (..),
6+ processLine,
7+ unmaskLine,
8+ )
9+where
10+
11+import Control.Monad
12+import Data.Char (isSpace)
13+import qualified Data.List as L
14+import Data.Maybe (isJust)
15+import Data.String
16+import Data.Text (Text)
17+import qualified Data.Text as T
18+
19+-- | State of the CPP processor.
20+data State
21+ = -- | Outside of CPP directives
22+ Outside
23+ | -- | In a conditional expression
24+ InConditional
25+ | -- | In a continuation (after @\\@)
26+ InContinuation
27+ deriving (Eq, Show)
28+
29+-- | Automatically mask the line when needed and update the 'State'.
30+processLine :: String -> State -> (String, State)
31+processLine line state
32+ | for "define " = (masked, state')
33+ | for "include " = (masked, state')
34+ | for "undef " = (masked, state')
35+ | for "ifdef " = (masked, InConditional)
36+ | for "ifndef " = (masked, InConditional)
37+ | for "if " = (masked, InConditional)
38+ | for "else" = (masked, InConditional)
39+ | for "elif" = (masked, InConditional)
40+ | for "endif" = (masked, state')
41+ | otherwise =
42+ case state of
43+ Outside -> (line, Outside)
44+ InConditional -> (masked, InConditional)
45+ InContinuation -> (masked, state')
46+ where
47+ for directive = isJust $ do
48+ s <- dropWhile isSpace <$> L.stripPrefix "#" line
49+ void (L.stripPrefix directive s)
50+ masked = maskLine line
51+ state' =
52+ if "\\" `L.isSuffixOf` line
53+ then InContinuation
54+ else Outside
55+
56+-- | Mask the given line.
57+maskLine :: String -> String
58+maskLine x = maskPrefix ++ x
59+
60+-- | If the given line is masked, unmask it. Otherwise return the line
61+-- unchanged.
62+unmaskLine :: Text -> Text
63+unmaskLine x =
64+ case T.stripPrefix maskPrefix (T.stripStart x) of
65+ Nothing -> x
66+ Just x' -> x'
67+
68+-- | Mask prefix for CPP.
69+maskPrefix :: IsString s => s
70+maskPrefix = "-- ORMOLU_CPP_MASK"
src/Ormolu/Processing/Postprocess.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ViewPatterns #-}
3+
4+-- | Postprocessing for the results of printing.
5+module Ormolu.Processing.Postprocess
6+ ( postprocess,
7+ )
8+where
9+
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+import Ormolu.Processing.Common
13+import qualified Ormolu.Processing.Cpp as Cpp
14+
15+-- | Postprocess output of the formatter.
16+postprocess ::
17+ -- | Desired indentation level
18+ Int ->
19+ -- | Input to process
20+ Text ->
21+ Text
22+postprocess indent =
23+ T.unlines
24+ . fmap indentLine
25+ . fmap Cpp.unmaskLine
26+ . filter (not . magicComment)
27+ . T.lines
28+ where
29+ magicComment (T.stripStart -> x) =
30+ x == startDisabling || x == endDisabling
31+ indentLine x = T.replicate indent " " <> x
src/Ormolu/Processing/Preprocess.hsnew file+149
@@ -0,0 +1,149 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE RecordWildCards #-}
4+
5+-- | Preprocessing for input source code.
6+module Ormolu.Processing.Preprocess
7+ ( preprocess,
8+ )
9+where
10+
11+import Control.Monad
12+import Data.Char (isSpace)
13+import qualified Data.List as L
14+import Data.Maybe (isJust, maybeToList)
15+import FastString
16+import Ormolu.Config (RegionDeltas (..))
17+import Ormolu.Parser.Shebang (isShebang)
18+import Ormolu.Processing.Common
19+import qualified Ormolu.Processing.Cpp as Cpp
20+import SrcLoc
21+
22+-- | Transform given input possibly returning comments extracted from it.
23+-- This handles LINE pragmas, CPP, shebangs, and the magic comments for
24+-- enabling\/disabling of Ormolu.
25+preprocess ::
26+ -- | File name, just to use in the spans
27+ FilePath ->
28+ -- | Input to process
29+ String ->
30+ -- | Region deltas
31+ RegionDeltas ->
32+ -- | Literal prefix, pre-processed input, literal suffix, extra comments
33+ (String, String, String, [Located String])
34+preprocess path input RegionDeltas {..} =
35+ go 1 OrmoluEnabled Cpp.Outside id id regionLines
36+ where
37+ (prefixLines, otherLines) = splitAt regionPrefixLength (lines input)
38+ (regionLines, suffixLines) =
39+ let regionLength = length otherLines - regionSuffixLength
40+ in splitAt regionLength otherLines
41+ go !n ormoluState cppState inputSoFar csSoFar = \case
42+ [] ->
43+ let input' = unlines (inputSoFar [])
44+ in ( unlines prefixLines,
45+ case ormoluState of
46+ OrmoluEnabled -> input'
47+ OrmoluDisabled -> input' ++ endDisabling,
48+ unlines suffixLines,
49+ csSoFar []
50+ )
51+ (x : xs) ->
52+ let (x', ormoluState', cppState', cs) =
53+ processLine path n ormoluState cppState x
54+ in go
55+ (n + 1)
56+ ormoluState'
57+ cppState'
58+ (inputSoFar . (x' :))
59+ (csSoFar . (maybeToList cs ++))
60+ xs
61+
62+-- | Transform a given line possibly returning a comment extracted from it.
63+processLine ::
64+ -- | File name, just to use in the spans
65+ FilePath ->
66+ -- | Line number of this line
67+ Int ->
68+ -- | Whether Ormolu is currently enabled
69+ OrmoluState ->
70+ -- | CPP state
71+ Cpp.State ->
72+ -- | The actual line
73+ String ->
74+ -- | Adjusted line and possibly a comment extracted from it
75+ (String, OrmoluState, Cpp.State, Maybe (Located String))
76+processLine path n ormoluState Cpp.Outside line
77+ | "{-# LINE" `L.isPrefixOf` line =
78+ let (pragma, res) = getPragma line
79+ size = length pragma
80+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
81+ in (res, ormoluState, Cpp.Outside, Just (L ss pragma))
82+ | isOrmoluEnable line =
83+ case ormoluState of
84+ OrmoluEnabled ->
85+ (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
86+ OrmoluDisabled ->
87+ (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
88+ | isOrmoluDisable line =
89+ case ormoluState of
90+ OrmoluEnabled ->
91+ (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing)
92+ OrmoluDisabled ->
93+ (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing)
94+ | isShebang line =
95+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length line))
96+ in ("", ormoluState, Cpp.Outside, Just (L ss line))
97+ | otherwise =
98+ let (line', cppState') = Cpp.processLine line Cpp.Outside
99+ in (line', ormoluState, cppState', Nothing)
100+ where
101+ mkSrcLoc' = mkSrcLoc (mkFastString path) n
102+processLine _ _ ormoluState cppState line =
103+ let (line', cppState') = Cpp.processLine line cppState
104+ in (line', ormoluState, cppState', Nothing)
105+
106+-- | Take a line pragma and output its replacement (where line pragma is
107+-- replaced with spaces) and the contents of the pragma itself.
108+getPragma ::
109+ -- | Pragma line to analyze
110+ String ->
111+ -- | Contents of the pragma and its replacement line
112+ (String, String)
113+getPragma [] = error "Ormolu.Preprocess.getPragma: input must not be empty"
114+getPragma s@(x : xs)
115+ | "#-}" `L.isPrefixOf` s = ("#-}", " " ++ drop 3 s)
116+ | otherwise =
117+ let (prag, remline) = getPragma xs
118+ in (x : prag, ' ' : remline)
119+
120+-- | Canonical enable marker.
121+enableMarker :: String
122+enableMarker = "{- ORMOLU_ENABLE -}"
123+
124+-- | Canonical disable marker.
125+disableMarker :: String
126+disableMarker = "{- ORMOLU_DISABLE -}"
127+
128+-- | Return 'True' if the given string is an enabling marker.
129+isOrmoluEnable :: String -> Bool
130+isOrmoluEnable = magicComment "ORMOLU_ENABLE"
131+
132+-- | Return 'True' if the given string is a disabling marker.
133+isOrmoluDisable :: String -> Bool
134+isOrmoluDisable = magicComment "ORMOLU_DISABLE"
135+
136+-- | Construct a function for whitespace-insensitive matching of string.
137+magicComment ::
138+ -- | What to expect
139+ String ->
140+ -- | String to test
141+ String ->
142+ -- | Whether or not the two strings watch
143+ Bool
144+magicComment expected s0 = isJust $ do
145+ let trim = dropWhile isSpace
146+ s1 <- trim <$> L.stripPrefix "{-" (trim s0)
147+ s2 <- trim <$> L.stripPrefix expected s1
148+ s3 <- L.stripPrefix "-}" s2
149+ guard (all isSpace s3)
src/Ormolu/Utils.hs+91−10
@@ -1,40 +1,66 @@
1{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ViewPatterns #-}
3
4
4-- | Random utilities used by the code.
5-- | Random utilities used by the code.
5module Ormolu.Utils
6module Ormolu.Utils
7+ ( RelativePos (..),
8+ attachRelativePos,
6− ( combineSrcSpans',
9+ combineSrcSpans',
7− isModule,
8 notImplemented,
10 notImplemented,
9 showOutputable,
11 showOutputable,
10 splitDocString,
12 splitDocString,
13+ typeArgToType,
14+ unSrcSpan,
15+ incSpanLine,
16+ separatedByBlank,
17+ separatedByBlankNE,
18+ onTheSameLine,
19+ removeIndentation,
11 )
20 )
12where
21where
13
22
14−import Data.Data (Data, showConstr, toConstr)
23+import Data.Char (isSpace)
15import Data.List (dropWhileEnd)
24import Data.List (dropWhileEnd)
16import Data.List.NonEmpty (NonEmpty (..))
25import Data.List.NonEmpty (NonEmpty (..))
26+import qualified Data.List.NonEmpty as NE
27+import Data.Maybe (fromMaybe)
17import Data.Text (Text)
28import Data.Text (Text)
18import qualified Data.Text as T
29import qualified Data.Text as T
19−import HsDoc (HsDocString, unpackHDS)
30+import GHC
31+import GHC.DynFlags (baseDynFlags)
20import qualified Outputable as GHC
32import qualified Outputable as GHC
21−import SrcLoc
33+
34+-- | Relative positions in a list.
35+data RelativePos
36+ = SinglePos
37+ | FirstPos
38+ | MiddlePos
39+ | LastPos
40+ deriving (Eq, Show)
41+
42+-- | Attach 'RelativePos'es to elements of a given list.
43+attachRelativePos :: [a] -> [(RelativePos, a)]
44+attachRelativePos = \case
45+ [] -> []
46+ [x] -> [(SinglePos, x)]
47+ (x : xs) -> (FirstPos, x) : markLast xs
48+ where
49+ markLast [] = []
50+ markLast [x] = [(LastPos, x)]
51+ markLast (x : xs) = (MiddlePos, x) : markLast xs
22
52
23-- | Combine all source spans from the given list.
53-- | Combine all source spans from the given list.
24combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
54combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
25combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
55combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
26
56
27−-- | Return 'True' if given element of AST is module.
28−isModule :: Data a => a -> Bool
29−isModule x = showConstr (toConstr x) == "HsModule"
30−
31-- | Placeholder for things that are not yet implemented.
57-- | Placeholder for things that are not yet implemented.
32notImplemented :: String -> a
58notImplemented :: String -> a
33notImplemented msg = error $ "not implemented yet: " ++ msg
59notImplemented msg = error $ "not implemented yet: " ++ msg
34
60
35-- | Pretty-print an 'GHC.Outputable' thing.
61-- | Pretty-print an 'GHC.Outputable' thing.
36showOutputable :: GHC.Outputable o => o -> String
62showOutputable :: GHC.Outputable o => o -> String
37−showOutputable = GHC.showSDocUnsafe . GHC.ppr
63+showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
38
64
39-- | Split and normalize a doc string. The result is a list of lines that
65-- | Split and normalize a doc string. The result is a list of lines that
40-- make up the comment.
66-- make up the comment.
@@ -72,3 +98,58 @@ splitDocString docStr =
72 in if leadingSpace x
98 in if leadingSpace x
73 then dropSpace <$> xs
99 then dropSpace <$> xs
74 else xs
100 else xs
101+
102+-- | Get 'LHsType' out of 'LHsTypeArg'.
103+typeArgToType :: LHsTypeArg p -> LHsType p
104+typeArgToType = \case
105+ HsValArg tm -> tm
106+ HsTypeArg _ ty -> ty
107+ HsArgPar _ -> notImplemented "HsArgPar"
108+
109+-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
110+unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
111+unSrcSpan = \case
112+ RealSrcSpan r -> Just r
113+ 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+
129+-- | Do two declarations have a blank between them?
130+separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
131+separatedByBlank loc a b =
132+ fromMaybe False $ do
133+ endA <- srcSpanEndLine <$> unSrcSpan (loc a)
134+ startB <- srcSpanStartLine <$> unSrcSpan (loc b)
135+ pure (startB - endA >= 2)
136+
137+-- | Do two declaration groups have a blank between them?
138+separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
139+separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
140+
141+-- | Return 'True' if one span ends on the same line the second one starts.
142+onTheSameLine :: SrcSpan -> SrcSpan -> Bool
143+onTheSameLine a b =
144+ isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))
145+
146+-- | Remove indentation from a given 'String'. Return the input with
147+-- indentation removed and the detected indentation level.
148+removeIndentation :: String -> (String, Int)
149+removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)
150+ where
151+ n = minimum (getIndent <$> xs)
152+ getIndent y =
153+ if all isSpace y
154+ then 0
155+ else length (takeWhile isSpace y)
tests/Ormolu/Parser/PragmaSpec.hs+1−1
@@ -4,7 +4,7 @@ import Ormolu.Parser.Pragma
4import Test.Hspec
4import Test.Hspec
5
5
6spec :: Spec
6spec :: Spec
7−spec = do
7+spec =
8 describe "parsePragma" $ do
8 describe "parsePragma" $ do
9 stdTest "{-# LANGUAGE Foo #-}" (Just (PragmaLanguage ["Foo"]))
9 stdTest "{-# LANGUAGE Foo #-}" (Just (PragmaLanguage ["Foo"]))
10 stdTest "{-# language Foo #-}" (Just (PragmaLanguage ["Foo"]))
10 stdTest "{-# language Foo #-}" (Just (PragmaLanguage ["Foo"]))
tests/Ormolu/PrinterSpec.hs+7−10
@@ -1,9 +1,6 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2
2
3−module Ormolu.PrinterSpec
3+module Ormolu.PrinterSpec (spec) where
4− ( spec,
5− )
6−where
7
4
8import Control.Exception
5import Control.Exception
9import Control.Monad
6import Control.Monad
@@ -15,7 +12,7 @@ import qualified Data.Text.IO as T
15import Ormolu
12import Ormolu
16import Path
13import Path
17import Path.IO
14import Path.IO
18−import System.FilePath (addExtension, dropExtensions, splitExtensions)
15+import qualified System.FilePath as F
19import Test.Hspec
16import Test.Hspec
20
17
21spec :: Spec
18spec :: Spec
@@ -53,19 +50,19 @@ locateExamples =
53isInput :: Path Rel File -> Bool
50isInput :: Path Rel File -> Bool
54isInput path =
51isInput path =
55 let s = fromRelFile path
52 let s = fromRelFile path
56− (s', exts) = splitExtensions s
53+ (s', exts) = F.splitExtensions s
57 in exts == ".hs" && not ("-out" `isSuffixOf` s')
54 in exts == ".hs" && not ("-out" `isSuffixOf` s')
58
55
59-- | For given path of input file return expected name of output.
56-- | For given path of input file return expected name of output.
60deriveOutput :: Path Rel File -> IO (Path Rel File)
57deriveOutput :: Path Rel File -> IO (Path Rel File)
61deriveOutput path =
58deriveOutput path =
62 parseRelFile $
59 parseRelFile $
63− addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
60+ F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs"
64
61
65-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
62-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
66-- It also prints multi-line snippets in a more readable form.
63-- It also prints multi-line snippets in a more readable form.
67shouldMatch :: Bool -> Text -> Text -> Expectation
64shouldMatch :: Bool -> Text -> Text -> Expectation
68−shouldMatch idempotencyTest actual expected =
65+shouldMatch idempotenceTest actual expected =
69 when (actual /= expected) . expectationFailure $
66 when (actual /= expected) . expectationFailure $
70 unlines
67 unlines
71 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
68 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
@@ -75,8 +72,8 @@ shouldMatch idempotencyTest actual expected =
75 ]
72 ]
76 where
73 where
77 pass =
74 pass =
78− if idempotencyTest
75+ if idempotenceTest
79− then "idempotency pass"
76+ then "idempotence pass"
80 else "first pass"
77 else "first pass"
81
78
82examplesDir :: Path Rel Dir
79examplesDir :: Path Rel Dir