git.iko.soy/ormolu
on master help sign in
swap
dec158c91 ahead, 0 behind
256 files changed+3574−1480
since splitsnapshots
unifiedsplit
.buildkite/pipeline.yml+14−3 .github/workflows/binaries.yml+39 .github/workflows/build.sh+7 CHANGELOG.md+133−3 CONTRIBUTING.md+1−1 DESIGN.md+11−11 README.md+54−13 app/Main.hs+48−36 data/examples/declaration/annotation/annotation-out.hs+1 data/examples/declaration/data/existential-multiline-out.hs+12 data/examples/declaration/data/existential-multiline.hs+7 data/examples/declaration/data/field-layout/gadt-out.hs+2−1 data/examples/declaration/data/field-layout/record-out.hs+9−9 data/examples/declaration/data/gadt/multiline-out.hs+1−1 data/examples/declaration/data/multiline-arg-parens-out.hs+1−1 data/examples/declaration/data/partly-documented-out.hs+5 data/examples/declaration/data/partly-documented.hs+2 data/examples/declaration/data/record-multi-const-out.hs+17 data/examples/declaration/data/record-multi-const.hs+13 data/examples/declaration/data/record-out.hs+19−20 data/examples/declaration/data/simple-broken-out.hs+1−2 data/examples/declaration/data/unnamed-field-comment-0-out.hs+7 data/examples/declaration/data/unnamed-field-comment-0.hs+5 data/examples/declaration/data/unnamed-field-comment-1-out.hs+5 data/examples/declaration/data/unnamed-field-comment-1.hs+4 data/examples/declaration/data/with-comment-out.hs+4 data/examples/declaration/data/with-comment.hs+5 data/examples/declaration/data/with-weird-haddock-out.hs+4 data/examples/declaration/data/with-weird-haddock.hs+2 data/examples/declaration/instance/data-family-instances-gadt-out.hs+4−2 data/examples/declaration/instance/data-family-instances-newtype-out.hs+3−4 data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs−1 data/examples/declaration/signature/type/multi-value-out.hs+5 data/examples/declaration/signature/type/multi-value.hs+5 data/examples/declaration/signature/type/unrelated-out.hs+4 data/examples/declaration/signature/type/unrelated.hs+4 data/examples/declaration/splice/grouped-splices-out.hs+3 data/examples/declaration/splice/grouped-splices.hs+3 data/examples/declaration/splice/splice-decl.hs−1 data/examples/declaration/type-synonyms/with-weird-haddock-out.hs+3 data/examples/declaration/type-synonyms/with-weird-haddock.hs+1 data/examples/declaration/value/function/arg-breakpoints-out.hs+3 data/examples/declaration/value/function/arg-breakpoints.hs+3 data/examples/declaration/value/function/arrow/multiline-case-out.hs+8 data/examples/declaration/value/function/arrow/multiline-case.hs+7 data/examples/declaration/value/function/arrow/proc-applications-out.hs+6−5 data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+18−14 data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs+3−2 data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs+9−7 data/examples/declaration/value/function/arrow/proc-forms1-out.hs+8−6 data/examples/declaration/value/function/arrow/proc-forms2-out.hs+6−4 data/examples/declaration/value/function/arrow/proc-ifs-out.hs+6−4 data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+5−4 data/examples/declaration/value/function/arrow/recursive-procs-out.hs+14−10 data/examples/declaration/value/function/awkward-comment-0-out.hs+6 data/examples/declaration/value/function/awkward-comment-0.hs+5 data/examples/declaration/value/function/awkward-comment-1-out.hs+9 data/examples/declaration/value/function/awkward-comment-1.hs+7 data/examples/declaration/value/function/blank-lines-let-out.hs+6 data/examples/declaration/value/function/blank-lines-let.hs+9 data/examples/declaration/value/function/blank-lines-where-out.hs+6 data/examples/declaration/value/function/blank-lines-where.hs+7 data/examples/declaration/value/function/do/blocks-out.hs+1 data/examples/declaration/value/function/do/comment-alignment-out.hs+9 data/examples/declaration/value/function/do/comment-alignment.hs+9 data/examples/declaration/value/function/do/comment-spacing-out.hs+7 data/examples/declaration/value/function/do/comment-spacing.hs+7 data/examples/declaration/value/function/do/recursive-do-rec-out.hs+5 data/examples/declaration/value/function/if-with-comment-out.hs+8 data/examples/declaration/value/function/if-with-comment.hs+8 data/examples/declaration/value/function/implicit-params-out.hs+1 data/examples/declaration/value/function/implicit-params.hs+2 data/examples/declaration/value/function/infix/dollar-chains-out.hs+3−3 data/examples/declaration/value/function/infix/hanging-out.hs+4−3 data/examples/declaration/value/function/infix/lenses-out.hs+8−7 data/examples/declaration/value/function/let-single-line-out.hs−1 data/examples/declaration/value/function/list-notation-0-out.hs+5 data/examples/declaration/value/function/list-notation-0.hs+5 data/examples/declaration/value/function/list-notation-1-out.hs+8 data/examples/declaration/value/function/list-notation-1.hs+7 data/examples/declaration/value/function/list-notation-2-out.hs+6 data/examples/declaration/value/function/list-notation-2.hs+5 data/examples/declaration/value/function/list-notation-3-out.hs+12 data/examples/declaration/value/function/list-notation-3.hs+10 data/examples/declaration/value/function/multi-way-if-out.hs+4−2 data/examples/declaration/value/function/operator-comments-2-out.hs+5 data/examples/declaration/value/function/operator-comments-2.hs+4 data/examples/declaration/value/function/operators-out.hs → data/examples/declaration/value/function/operators-0-out.hs data/examples/declaration/value/function/operators.hs → data/examples/declaration/value/function/operators-0.hs data/examples/declaration/value/function/operators-1-out.hs+4 data/examples/declaration/value/function/operators-1.hs+3 data/examples/declaration/value/function/operators-2-out.hs+4 data/examples/declaration/value/function/operators-2.hs+4 data/examples/declaration/value/function/operators-3-out.hs+3 data/examples/declaration/value/function/operators-3.hs+3 data/examples/declaration/value/function/operators-4-out.hs+3 data/examples/declaration/value/function/operators-4.hs+3 data/examples/declaration/value/function/operators-5-out.hs+5 data/examples/declaration/value/function/operators-5.hs+4 data/examples/declaration/value/function/operators-6-out.hs+9 data/examples/declaration/value/function/operators-6.hs+7 data/examples/declaration/value/function/record-constructors-out.hs → data/examples/declaration/value/function/record/constructors-out.hs data/examples/declaration/value/function/record-constructors.hs → data/examples/declaration/value/function/record/constructors.hs data/examples/declaration/value/function/record-dot-out.hs → data/examples/declaration/value/function/record/dot-out.hs data/examples/declaration/value/function/record-dot.hs → data/examples/declaration/value/function/record/dot.hs data/examples/declaration/value/function/record/hanging-after-equal-con-out.hs+8 data/examples/declaration/value/function/record/hanging-after-equal-con.hs+7 data/examples/declaration/value/function/record/hanging-after-equal-update-out.hs+8 data/examples/declaration/value/function/record/hanging-after-equal-update.hs+7 data/examples/declaration/value/function/record-inter-comments-out.hs → data/examples/declaration/value/function/record/inter-comments-out.hs data/examples/declaration/value/function/record-inter-comments.hs → data/examples/declaration/value/function/record/inter-comments.hs data/examples/declaration/value/function/record-updaters-out.hs → data/examples/declaration/value/function/record/updaters-out.hs data/examples/declaration/value/function/record-updaters.hs → data/examples/declaration/value/function/record/updaters.hs data/examples/declaration/value/function/record-wildcards-out.hs → data/examples/declaration/value/function/record/wildcards-out.hs data/examples/declaration/value/function/record-wildcards.hs → data/examples/declaration/value/function/record/wildcards.hs data/examples/declaration/value/function/type-applications-and-splice-out.hs+4 data/examples/declaration/value/function/type-applications-and-splice.hs+4 data/examples/import/deduplication-bug-out.hs+6 data/examples/import/deduplication-bug.hs+6 data/examples/import/explicit-imports-out.hs+4−4 data/examples/import/explicit-imports-with-comments-out.hs+3−2 data/examples/import/merging-0-out.hs+3 data/examples/import/merging-0.hs+4 data/examples/import/merging-1-out.hs+2 data/examples/import/merging-1.hs+3 data/examples/import/merging-2-out.hs+2 data/examples/import/merging-2.hs+4 data/examples/import/misc-out.hs−6 data/examples/import/nested-explicit-imports-out.hs+6−6 data/examples/import/qualified-post-out.hs+1−1 data/examples/import/qualified-prelude-out.hs+1−1 data/examples/import/simple-out.hs+2−3 data/examples/import/simple.hs+2 data/examples/import/sorted-export-list-out.hs+1 data/examples/import/sorted-export-list.hs+1 data/examples/module-header/double-dot-with-names-out.hs+1−6 data/examples/module-header/multiline2.hs+2−2 data/examples/module-header/preceding-comment-with-haddock-out.hs+1−4 data/examples/module-header/singleline-empty-out.hs+1−4 data/examples/module-header/stack-header-0-out.hs+1 data/examples/module-header/stack-header-1-out.hs+1 data/examples/module-header/warning-pragma-multiline-out.hs+1−4 data/examples/module-header/warning-pragma-out.hs+3−1 data/examples/other/argument-comment-out.hs−1 data/examples/other/comment-glued-together-out.hs+7 data/examples/other/comment-glued-together.hs+6 data/examples/other/comment-trailing-space-out.hs+9 data/examples/other/comment-trailing-space.hs+9 data/examples/other/comment-two-blocks-out.hs+2−2 data/examples/other/cpp/continuation-out.hs+8 data/examples/other/cpp/continuation.hs+8 data/examples/other/cpp/lonely-hash-out.hs+14 data/examples/other/cpp/lonely-hash.hs+14 data/examples/other/cpp/separation-0a-out.hs+7 data/examples/other/cpp/separation-0a.hs+6 data/examples/other/cpp/separation-0b-out.hs+10 data/examples/other/cpp/separation-0b.hs+9 data/examples/other/cpp/separation-1a-out.hs+12 data/examples/other/cpp/separation-1a.hs+11 data/examples/other/cpp/separation-1b-out.hs+15 data/examples/other/cpp/separation-1b.hs+14 data/examples/other/cpp/separation-2a-out.hs+9 data/examples/other/cpp/separation-2a.hs+8 data/examples/other/cpp/separation-2b-out.hs+11 data/examples/other/cpp/separation-2b.hs+11 data/examples/other/cpp/shifted-out.hs+21 data/examples/other/cpp/shifted.hs+17 data/examples/other/cpp/simple-import-out.hs+14 data/examples/other/cpp/simple-import.hs+14 data/examples/other/disabling/indented-fragment-out.hs+7 data/examples/other/disabling/indented-fragment.hs+7 data/examples/other/disabling/single-definition-out.hs+10 data/examples/other/disabling/single-definition.hs+10 data/examples/other/disabling/whole-file-out.hs+10 data/examples/other/disabling/whole-file.hs+10 data/examples/other/inline-comment-0-out.hs+3 data/examples/other/inline-comment-0.hs+3 data/examples/other/inline-comment-1-out.hs+12 data/examples/other/inline-comment-1.hs+9 data/examples/other/multiline-forall-out.hs+1−2 data/examples/other/multiple-blank-line-comment-out.hs+9 data/examples/other/multiple-blank-line-comment.hs+10 data/examples/other/pragma-comments-after-out.hs+4 data/examples/other/pragma-comments-after.hs+3 data/examples/other/pragma-comments-out.hs+8 data/examples/other/pragma-comments.hs+11 data/examples/other/pragma-out.hs+1−4 data/examples/other/pragma-sorting-out.hs+1−2 default.nix+108−61 expected-failures/Agda.txt+11 expected-failures/aws.txt+9 expected-failures/distributed-process.txt+7 expected-failures/esqueleto.txt+7 expected-failures/fay.txt+18 expected-failures/hlint.txt+11 expected-failures/idris.txt+7 expected-failures/intero.txt+5 expected-failures/leksah.txt+5 expected-failures/lens.txt+3 expected-failures/pandoc.txt+9 expected-failures/pipes.txt+3 expected-failures/postgrest.txt+5 expected-failures/purescript.txt+18 expected-failures/tensorflow.txt+7 format.sh+6−4 nix/nixpkgs/default.nix+7−3 nix/ormolize/default.nix+29−13 nix/ormolize/ormolize.sh−17 ormolu.cabal+174−155 region-tests/expected-result-17-18.hs+17 region-tests/expected-result-6-7.hs+17 region-tests/expected-result-6-8.hs+16 region-tests/expected-result-9-12.hs+17 region-tests/expected-result-all.hs+21 region-tests/src.hs+17 shell.nix+4−2 src/GHC.hs−3 src/Ormolu.hs+10−7 src/Ormolu/Config.hs+62−23 src/Ormolu/Diff.hs+15−12 src/Ormolu/Exception.hs+4−11 src/Ormolu/Imports.hs+161−44 src/Ormolu/Parser.hs+52−100 src/Ormolu/Parser/CommentStream.hs+147−61 src/Ormolu/Parser/Pragma.hs+4−4 src/Ormolu/Parser/Result.hs+26−17 src/Ormolu/Parser/Shebang.hs+27 src/Ormolu/Printer.hs+17−11 src/Ormolu/Printer/Combinators.hs+39−29 src/Ormolu/Printer/Comments.hs+62−76 src/Ormolu/Printer/Internal.hs+149−96 src/Ormolu/Printer/Meat/Common.hs+13−10 src/Ormolu/Printer/Meat/Declaration.hs+76−57 src/Ormolu/Printer/Meat/Declaration.hs-boot−1 src/Ormolu/Printer/Meat/Declaration/Class.hs+2−2 src/Ormolu/Printer/Meat/Declaration/Data.hs+54−29 src/Ormolu/Printer/Meat/Declaration/Default.hs+2−2 src/Ormolu/Printer/Meat/Declaration/Instance.hs+5−9 src/Ormolu/Printer/Meat/Declaration/Rule.hs+2−2 src/Ormolu/Printer/Meat/Declaration/Signature.hs+29−27 src/Ormolu/Printer/Meat/Declaration/Type.hs+5−3 src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+5−5 src/Ormolu/Printer/Meat/Declaration/Value.hs+210−172 src/Ormolu/Printer/Meat/Declaration/Value.hs-boot−4 src/Ormolu/Printer/Meat/Declaration/Warning.hs+5−8 src/Ormolu/Printer/Meat/ImportExport.hs+26−20 src/Ormolu/Printer/Meat/Module.hs+23−20 src/Ormolu/Printer/Meat/Pragma.hs+22−12 src/Ormolu/Printer/Meat/Type.hs+48−27 src/Ormolu/Printer/Operators.hs+50−63 src/Ormolu/Processing/Common.hs+27 src/Ormolu/Processing/Cpp.hs+70 src/Ormolu/Processing/Postprocess.hs+31 src/Ormolu/Processing/Preprocess.hs+149 src/Ormolu/Utils.hs+74−15 tests/Ormolu/PrinterSpec.hs+4−7
.buildkite/pipeline.yml+14−3
@@ -1,7 +1,18 @@
11steps:
2− - label: Build and test
2+ - label: Build and test with GHC 8.6.5
3+ command: |
4+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc865
5+ timeout: 100
6+ - label: Build and test with GHC 8.8.4
7+ command: |
8+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc884
9+ timeout: 100
10+ - label: Build and test with GHC 8.10.1
11+ command: |
12+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc8101
13+ timeout: 100
14+ - wait
15+ - label: Check formatting
316 command: |
4− nix-build --keep-going --no-out-link
517 ./format.sh
618 git diff --exit-code --color=always
7− timeout: 100
.github/workflows/binaries.ymlnew file+39
@@ -0,0 +1,39 @@
1+name: Build binaries
2+on:
3+ release:
4+ types: [published]
5+jobs:
6+ build:
7+ strategy:
8+ fail-fast: false
9+ matrix:
10+ os: [ubuntu-latest, macOS-latest, windows-latest]
11+ runs-on: ${{ matrix.os }}
12+ steps:
13+ - uses: actions/checkout@v2
14+ - uses: actions/setup-haskell@v1
15+ if: runner.os != 'Linux'
16+ with:
17+ ghc-version: '8.10.1'
18+ cabal-version: '3.2'
19+ - name: Build Linux binary
20+ if: runner.os == 'Linux'
21+ run: |
22+ docker run \
23+ -v $(pwd):/mnt -w /mnt \
24+ utdemir/ghc-musl:v14-ghc8101 \
25+ bash .github/workflows/build.sh
26+ - name: Build ${{ runner.os }} binary
27+ if: runner.os != 'Linux'
28+ shell: bash
29+ run: |
30+ cabal build exe:ormolu
31+ cp $(find dist-newstyle \( -name ormolu -o -name ormolu.exe \) -type f) ormolu
32+ - uses: actions/upload-release-asset@v1
33+ env:
34+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
35+ with:
36+ upload_url: ${{ github.event.release.upload_url }}
37+ asset_path: ormolu
38+ asset_name: ormolu-${{ runner.os }}
39+ asset_content_type: application/octet-stream
.github/workflows/build.shnew file+7
@@ -0,0 +1,7 @@
1+set -e
2+
3+cabal update
4+cabal build exe:ormolu --enable-executable-static --ghc-options="-split-sections"
5+
6+cp $(find dist-newstyle -name ormolu -type f) .
7+strip -s ormolu
CHANGELOG.md+133−3
@@ -1,5 +1,126 @@
11## Unreleased
22
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+
3124* When given several files to format, Ormolu does not stop on the first
4125 failure, but tries to format all the files. [Issue
5126 502](https://github.com/tweag/ormolu/issues/502).
@@ -16,13 +137,22 @@
16137 now put on its own line. [Issue
17138 509](https://github.com/tweag/ormolu/issues/509).
18139
19−* Implemented support for the new language extension `ImportQualifiedPost`.
140+* Fixed the bug pertaining to rendering of arrow notation with multiline
141+ expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513).
20142
21−* Implemented support for the new language extension
22− `StandaloneKindSignatures`.
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).
23150
24151* Switched to `ghc-lib-parser-8.10.1`.
25152
153+* Implemented support for the new language extensions `ImportQualifiedPost`
154+ and `StandaloneKindSignatures`.
155+
26156## Ormolu 0.0.3.1
27157
28158* Fixed rendering of record updates with the record dot preprocessor syntax
CONTRIBUTING.md+1−1
@@ -30,7 +30,7 @@ Testing is performed as following:
3030* The result of printing is parsed back again and the AST is compared to the
3131 AST obtained from the original file. They should match.
3232* 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
3434 results in exactly the same output.
3535
3636Examples 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.
2424
2525We set for the following goals (mostly taken from
2626[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;
2828* Make reasonable use of screen space;
2929* Use linear space and computation time on the size of the input;
3030* Preserve comments;
@@ -140,8 +140,10 @@ impossible to guess what they'll be called on.
140140
141141### CPP
142142
143−Formatting a module which uses CPP directives won't be supported. Instead,
144−we hope for a solution to replace CPP to do conditional compilation.
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
146+do conditional compilation.
145147
146148There are the following challenges when formatting a module with CPP:
147149
@@ -180,14 +182,15 @@ True
180182```
181183
182184At the time of this writing, formatting this program with Hindent
183−produces the same output we would get if the CPP directives were
184−considered comments:
185+or Ormolu produces the same output we would get if the CPP directives
186+were considered comments:
185187
186188```
187−$ hindent --version
188−hindent 5.2.7
189+$ ormolu --version
190+ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115
191+using ghc-lib-parser 8.10.1.20200412
189192
190−$ hindent test.hs
193+$ ormolu --mode inplace test.hs
191194
192195$ cat test.hs
193196{-# LANGUAGE CPP #-}
@@ -227,9 +230,6 @@ to parse Haskell modules. If CPP is replaced with some language
227230extension or mechanism to do conditional compilation, all tools
228231will benefit from it.
229232
230−Therefore, CPP won't be supported. If the CPP extension
231−is enabled, we should signal an error right away.
232−
233233### Printing
234234
235235Just pretty-printing code (following the approach of Hindent) seems sane. It
README.md+54−13
@@ -22,7 +22,7 @@ the following goals in mind:
2222* That formatting style aims to result in minimal diffs while still
2323 remaining very close to “conventional” Haskell formatting people use.
2424* 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.
2626* Idempotence: formatting already formatted code doesn't change it.
2727* Be well-tested and robust to the point that it can be used in large
2828 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.
4545
4646```console
4747$ cat stack.yaml
48−resolver: lts-14.3
48+resolver: lts-16.0
4949packages:
5050- '.'
5151
52−$ stack build
52+$ stack build # to build
53+$ stack install # to install
5354```
5455
5556To use Ormolu directly from GitHub with Nix, this snippet may come in handy:
@@ -91,21 +92,44 @@ formatted output.
9192$ ormolu --mode inplace Module.hs
9293```
9394
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+
94122## Current limitations
95123
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.
97129* Input modules should be parsable by Haddock, which is a bit stricter
98130 criterion than just being valid Haskell modules.
99131* Various minor idempotence issues, most of them are related to comments.
100132
101−## Editor integration
102−
103−We know of the following editor integrations:
104−
105−* [Emacs][emacs-package]
106−* [VS Code][vs-code-plugin]
107−* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu]
108−
109133## Running on Hackage
110134
111135It's possible to try Ormolu on arbitrary packages from Hackage. For that
@@ -120,6 +144,22 @@ also contain formatted `.hs` files for inspection and original inputs with
120144`.hs-original` extension (those are with CPP dropped, exactly what is fed
121145into Ormolu).
122146
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+
123163## Contributing
124164
125165See [CONTRIBUTING.md][contributing].
@@ -130,7 +170,7 @@ See [LICENSE.md][license].
130170
131171Copyright © 2018–present Tweag I/O
132172
133−[design]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
173+[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
134174[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md
135175[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md
136176[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
@@ -138,3 +178,4 @@ Copyright © 2018–present Tweag I/O
138178[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode
139179[vim-ormolu]: https://github.com/sdiehl/vim-ormolu
140180[neoformat]: https://github.com/sbdchd/neoformat
181+[aur]: https://aur.archlinux.org/packages/ormolu
app/Main.hs+48−36
@@ -4,13 +4,11 @@
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE TypeApplications #-}
66
7−module Main
8− ( main,
9− )
10−where
7+module Main (main) where
118
129import Control.Exception (SomeException, displayException, try)
1310import Control.Monad
11+import Data.Bool (bool)
1412import Data.Either (lefts)
1513import Data.List (intercalate, sort)
1614import qualified Data.Text.IO as TIO
@@ -37,9 +35,8 @@ main = withPrettyOrmoluExceptions $ do
3735 -- It is possible to get IOException, error's and 'OrmoluException's
3836 -- from 'formatOne', so we just catch everything.
3937 errs <-
40− lefts <$> mapM (try @SomeException . formatOne' . Just) xs
38+ lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)
4139 unless (null errs) $ do
42− hPutStrLn stderr "Some files failed to format:\n"
4340 mapM_ (hPutStrLn stderr . displayException) errs
4441 exitWith (ExitFailure 102)
4542
@@ -48,7 +45,7 @@ formatOne ::
4845 -- | Mode of operation
4946 Mode ->
5047 -- | Configuration
51− Config ->
48+ Config RegionIndices ->
5249 -- | File to format or stdin as 'Nothing'
5350 Maybe FilePath ->
5451 IO ()
@@ -64,15 +61,19 @@ formatOne mode config = \case
6461 -- 101 is different from all the other exit codes we already use.
6562 exitWith (ExitFailure 101)
6663 Just inputFile -> do
67− r <- ormoluFile config inputFile
64+ originalInput <- TIO.readFile inputFile
65+ formattedInput <- ormoluFile config inputFile
6866 case mode of
6967 Stdout ->
70− TIO.putStr r
71− InPlace ->
72− TIO.writeFile inputFile r
68+ TIO.putStr formattedInput
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) $
74+ TIO.writeFile inputFile formattedInput
7375 Check -> do
74− r' <- TIO.readFile inputFile
75− when (r /= r') $
76+ when (formattedInput /= originalInput) $
7677 -- 100 is different to all the other exit code that are emitted
7778 -- either from an 'OrmoluException' or from 'error' and
7879 -- 'notImplemented'.
@@ -81,15 +82,14 @@ formatOne mode config = \case
8182----------------------------------------------------------------------------
8283-- Command line options parsing.
8384
84−data Opts
85− = Opts
86− { -- | Mode of operation
87− optMode :: !Mode,
88− -- | Ormolu 'Config'
89− optConfig :: !Config,
90− -- | Haskell source files to format or stdin (when the list is empty)
91− optInputFiles :: ![FilePath]
92− }
85+data Opts = Opts
86+ { -- | Mode of operation
87+ optMode :: !Mode,
88+ -- | Ormolu 'Config'
89+ optConfig :: !(Config RegionIndices),
90+ -- | Haskell source files to format or stdin (when the list is empty)
91+ optInputFiles :: ![FilePath]
92+ }
9393
9494-- | Mode of operation.
9595data Mode
@@ -139,20 +139,25 @@ optsParserInfo =
139139optsParser :: Parser Opts
140140optsParser =
141141 Opts
142− <$> (option parseMode . mconcat)
143− [ long "mode",
144− short 'm',
145− metavar "MODE",
146− value Stdout,
147− help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"
148− ]
142+ <$> ( (fmap (bool Stdout InPlace) . switch . mconcat)
143+ [ short 'i',
144+ help "A shortcut for --mode inplace"
145+ ]
146+ <|> (option parseMode . mconcat)
147+ [ long "mode",
148+ short 'm',
149+ metavar "MODE",
150+ value Stdout,
151+ help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"
152+ ]
153+ )
149154 <*> configParser
150155 <*> (many . strArgument . mconcat)
151156 [ metavar "FILE",
152157 help "Haskell source files to format or stdin (default)"
153158 ]
154159
155−configParser :: Parser Config
160+configParser :: Parser (Config RegionIndices)
156161configParser =
157162 Config
158163 <$> (fmap (fmap DynOption) . many . strOption . mconcat)
@@ -172,15 +177,22 @@ configParser =
172177 help "Output information useful for debugging"
173178 ]
174179 <*> (switch . mconcat)
175− [ long "tolerate-cpp",
176− short 'p',
177− help "Do not fail if CPP pragma is present"
178− ]
179− <*> (switch . mconcat)
180− [ long "check-idempotency",
180+ [ long "check-idempotence",
181181 short 'c',
182182 help "Fail if formatting is not idempotent"
183183 ]
184+ <*> ( RegionIndices
185+ <$> (optional . option auto . mconcat)
186+ [ long "start-line",
187+ metavar "START",
188+ help "Start line of the region to format (starts from 1)"
189+ ]
190+ <*> (optional . option auto . mconcat)
191+ [ long "end-line",
192+ metavar "END",
193+ help "End line of the region to format (inclusive)"
194+ ]
195+ )
184196
185197----------------------------------------------------------------------------
186198-- Helpers
data/examples/declaration/annotation/annotation-out.hs+1
@@ -18,4 +18,5 @@ foo = 5
1818
1919data Foo = Foo Int
2020{-# ANN type Foo ("HLint: ignore") #-}
21+
2122{- Comment -}
data/examples/declaration/data/existential-multiline-out.hs+12
@@ -3,3 +3,15 @@
33data Foo
44 = forall a. MkFoo a (a -> Bool)
55 | 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 @@
33data Foo
44 = forall a. MkFoo a (a -> Bool)
55 | forall a. Eq a => MkBar a
6+
7+data Bar = forall x y.
8+ Bar x y x y
9+
10+data Baz = forall x y.
11+ Baz x y x
12+ y
data/examples/declaration/data/field-layout/gadt-out.hs+2−1
@@ -6,5 +6,6 @@ data Foo a b where
66 Foo :: Foo Int Int
77 -- | Something else
88 Bar ::
9− Foo Char
9+ Foo
10+ Char
1011 Char
data/examples/declaration/data/field-layout/record-out.hs+9−9
@@ -1,12 +1,12 @@
11module Main where
22
33-- | Foo.
4−data Foo
5− = Foo
6− { -- | Something
7− foo :: Foo Int Int,
8− -- | Something else
9− bar ::
10− Bar Char
11− Char
12− }
4+data Foo = Foo
5+ { -- | Something
6+ foo :: Foo Int Int,
7+ -- | Something else
8+ bar ::
9+ Bar
10+ Char
11+ Char
12+ }
data/examples/declaration/data/gadt/multiline-out.hs+1−1
@@ -8,7 +8,7 @@ data Foo a where
88 Foo ::
99 forall a b.
1010 (Show a, Eq b) => -- foo
11− -- bar
11+ -- bar
1212 a ->
1313 b ->
1414 Foo 'Int
data/examples/declaration/data/multiline-arg-parens-out.hs+1−1
@@ -5,6 +5,6 @@ data Foo
55 = Foo
66 Bar
77 (Set Baz) -- and here we go
8− -- and that's it
8+ -- and that's it
99 Text
1010 deriving (Eq)
data/examples/declaration/data/partly-documented-out.hsnew file+5
@@ -0,0 +1,5 @@
1+data Optimisation
2+ = PETransform
3+ | -- | partial eval and associated transforms
4+ GeneralisedNatHack
5+ deriving (Show, Eq, Generic)
data/examples/declaration/data/partly-documented.hsnew file+2
@@ -0,0 +1,2 @@
1+data Optimisation = PETransform | GeneralisedNatHack -- ^ partial eval and associated transforms
2+ deriving (Show, Eq, Generic)
data/examples/declaration/data/record-multi-const-out.hsnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+-- | Something.
4+data Foo
5+ = Foo
6+ { -- | X
7+ fooX :: Int,
8+ -- | Y
9+ fooY :: Int
10+ }
11+ | Bar
12+ { -- | X
13+ barX :: Int,
14+ -- | Y
15+ barY :: Int
16+ }
17+ deriving (Eq, Show)
data/examples/declaration/data/record-multi-const.hsnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+-- | Something.
4+
5+data Foo = Foo
6+ { fooX :: Int -- ^ X
7+ , fooY :: Int -- ^ Y
8+ } |
9+ Bar
10+ { barX :: Int -- ^ X
11+ , barY :: Int -- ^ Y
12+ }
13+ deriving (Eq, Show)
data/examples/declaration/data/record-out.hs+19−20
@@ -1,24 +1,23 @@
11module Main where
22
33-- | Something.
4−data Foo
5− = Foo
6− { -- | X
7− fooX :: Int,
8− -- | Y
9− fooY :: Int,
10− -- | BarBaz
11− fooBar, fooBaz :: NonEmpty (Identity Bool),
12− -- | GagGog
13− fooGag,
14− fooGog ::
15− NonEmpty
16− ( Indentity
17− Bool
18− ),
19− -- | Huh!
20− fooFoo,
21− barBar ::
22− Int
23− }
4+data Foo = Foo
5+ { -- | X
6+ fooX :: Int,
7+ -- | Y
8+ fooY :: Int,
9+ -- | BarBaz
10+ fooBar, fooBaz :: NonEmpty (Identity Bool),
11+ -- | GagGog
12+ fooGag,
13+ fooGog ::
14+ NonEmpty
15+ ( Indentity
16+ Bool
17+ ),
18+ -- | Huh!
19+ fooFoo,
20+ barBar ::
21+ Int
22+ }
2423 deriving (Eq, Show)
data/examples/declaration/data/simple-broken-out.hs+1−2
@@ -1,8 +1,7 @@
11module Main where
22
33-- | Here we go.
4−data Foo
5− = Foo {unFoo :: Int}
4+data Foo = Foo {unFoo :: Int}
65 deriving (Eq)
76
87-- | And once again.
data/examples/declaration/data/unnamed-field-comment-0-out.hsnew file+7
@@ -0,0 +1,7 @@
1+data Foo
2+ = -- | Bar
3+ Bar
4+ Field1
5+ -- ^ Field 1
6+ Field2
7+ -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-0.hsnew file+5
@@ -0,0 +1,5 @@
1+data Foo
2+ = -- | Bar
3+ Bar
4+ Field1 -- ^ Field 1
5+ Field2 -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-1-out.hsnew file+5
@@ -0,0 +1,5 @@
1+data X
2+ = B
3+ !Int
4+ -- ^ y
5+ C
data/examples/declaration/data/unnamed-field-comment-1.hsnew file+4
@@ -0,0 +1,4 @@
1+data X
2+ = B
3+ !Int -- ^ y
4+ C
data/examples/declaration/data/with-comment-out.hsnew file+4
@@ -0,0 +1,4 @@
1+data A
2+ = B -- C
3+ | -- D
4+ E
data/examples/declaration/data/with-comment.hsnew file+5
@@ -0,0 +1,5 @@
1+data A =
2+ B -- C
3+
4+ -- D
5+ | E
data/examples/declaration/data/with-weird-haddock-out.hsnew file+4
@@ -0,0 +1,4 @@
1+data PlusLevel' t
2+ = -- | @n + ℓ@.
3+ Plus Integer (LevelAtom' t)
4+ deriving (Show, Data)
data/examples/declaration/data/with-weird-haddock.hsnew file+2
@@ -0,0 +1,2 @@
1+data PlusLevel' t = Plus Integer (LevelAtom' t) -- ^ @n + ℓ@.
2+ deriving (Show, Data)
data/examples/declaration/instance/data-family-instances-gadt-out.hs+4−2
@@ -3,9 +3,11 @@
33
44data instance Bar Int a where
55 SameBar ::
6− Bar Int
6+ Bar
7+ Int
78 Int
89 CloseBar :: Bar Int Double
910 OtherBar ::
10− Bar Int
11+ Bar
12+ Int
1113 a
data/examples/declaration/instance/data-family-instances-newtype-out.hs+3−4
@@ -1,7 +1,6 @@
11{-# LANGUAGE GADTSyntax #-}
22{-# LANGUAGE TypeFamilies #-}
33
4−newtype instance Foo [Double]
5− = DoubleListFoo
6− { unDoubleListFoo :: Double
7− }
4+newtype instance Foo [Double] = DoubleListFoo
5+ { unDoubleListFoo :: Double
6+ }
data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs−1
@@ -1,3 +1,2 @@
11fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool)
2−
32fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)
data/examples/declaration/signature/type/multi-value-out.hs+5
@@ -2,6 +2,11 @@ foo, bar :: Int
22foo = 1
33bar = 2
44
5+a, b, c :: Int
6+a = 1
7+b = 2
8+c = 3
9+
510foo,
611 bar,
712 baz ::
data/examples/declaration/signature/type/multi-value.hs+5
@@ -2,6 +2,11 @@ foo, bar :: Int
22foo = 1
33bar = 2
44
5+a, b, c :: Int
6+a = 1
7+b = 2
8+c = 3
9+
510foo,
611 bar,
712 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
1515-- TemplateHaskell allows Q () at the top level
1616do
1717 pure []
18−
data/examples/declaration/type-synonyms/with-weird-haddock-out.hsnew file+3
@@ -0,0 +1,3 @@
1+type Elims =
2+ -- | eliminations ordered left-to-right.
3+ [Elim]
data/examples/declaration/type-synonyms/with-weird-haddock.hsnew file+1
@@ -0,0 +1 @@
1+type Elims = [Elim] -- ^ eliminations ordered left-to-right.
data/examples/declaration/value/function/arg-breakpoints-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arg-breakpoints.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arrow/multiline-case-out.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x <-
5+ case x of X -> x
6+ -<
7+ y
8+ a -< b
data/examples/declaration/value/function/arrow/multiline-case.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x
5+ <- case x of X -> x
6+ -< y
7+ a -< b
data/examples/declaration/value/function/arrow/proc-applications-out.hs+6−5
@@ -9,10 +9,11 @@ bar f x =
99 w
1010 )
1111 ->
12− f -< -- The value
13− ( x, -- Foo
14− w, -- Bar
15− z -- Baz
16− )
12+ f -- The value
13+ -<
14+ ( x, -- Foo
15+ w, -- Bar
16+ z -- Baz
17+ )
1718
1819baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+18−14
@@ -19,10 +19,11 @@ foo
1919 )
2020 ( b,
2121 d
22− ) -<
23− ( b + 1, -- Funnel into arrow
24− d * b
2522 )
23+ -<
24+ ( b + 1, -- Funnel into arrow
25+ d * b
26+ )
2627 if x `mod` y == 0 -- Basic condition
2728 then case e of -- Only left case is relevant
2829 Left
@@ -32,18 +33,20 @@ foo
3233 let v =
3334 u -- Actually never used
3435 ^ 2
35− in ( returnA -<
36− -- Just do the calculation
37− (x + y * z)
36+ in ( returnA
37+ -<
38+ -- Just do the calculation
39+ (x + y * z)
3840 )
3941 else do
4042 let u = x -- Let bindings bind expressions, not commands
41− -- Could pattern match directly on x
43+ -- Could pattern match directly on x
4244 i <- case u of
4345 0 -> (g . h -< u)
4446 n ->
45− ( ( h . g -<
46− y -- First actual use of y
47+ ( ( h . g
48+ -<
49+ y -- First actual use of y
4750 )
4851 )
4952 returnA -< ()
@@ -51,8 +54,9 @@ foo
5154 if i > 0
5255 then ma -< ()
5356 else returnA -< ()
54− returnA -<
55− ( i
56− + x
57− * y -- Just do the calculation
58− )
57+ returnA
58+ -<
59+ ( i
60+ + x
61+ * y -- Just do the calculation
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
1313
1414bazbar f = proc a -> do
1515 a <-
16− f -<
17− a
16+ f
17+ -<
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
1111 z <-
1212 h
1313 x
14− y -<
15− ( a,
16− b,
17− c
18− )
19− returnA -<
20− (x, y, z)
14+ y
15+ -<
16+ ( a,
17+ b,
18+ c
19+ )
20+ returnA
21+ -<
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 =
77 (|
88 test
99 ( h f
10− . h g -<
11− y x
12− . y z
10+ . h g
11+ -<
12+ y x
13+ . y z
1314 )
1415 ( h g
15− . h f -<
16− y z
17− . y x
16+ . h f
17+ -<
18+ y z
19+ . y x
1820 )
1921 |)
data/examples/declaration/value/function/arrow/proc-forms2-out.hs+6−4
@@ -12,9 +12,11 @@ bar2 f g h x =
1212
1313bar3 f g h x =
1414 proc (y, z) ->
15− ( (h f . h g) -<
16− (y x) . y z
15+ ( (h f . h g)
16+ -<
17+ (y x) . y z
1718 ) |||
18− ( (h g . h f) -<
19− y z . (y x)
19+ ( (h g . h f)
20+ -<
21+ y z . (y x)
2022 )
data/examples/declaration/value/function/arrow/proc-ifs-out.hs+6−4
@@ -6,8 +6,10 @@ bar f g = proc a ->
66 if f a
77 then
88 f
9− . g -<
10− a
9+ . g
10+ -<
11+ a
1112 else
12− g -<
13− b
13+ g
14+ -<
15+ b
data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+5−4
@@ -6,13 +6,14 @@ bar f g = proc a ->
66 ( ( (f)
77 ( g
88 )
9− ) -<
10− ( ( ( ( ( ( g
11− a
9+ )
10+ -<
11+ ( ( ( ( ( ( g
12+ a
13+ )
1214 )
1315 )
1416 )
1517 )
1618 )
17− )
1819 )
data/examples/declaration/value/function/arrow/recursive-procs-out.hs+14−10
@@ -3,17 +3,21 @@
33foo f g = proc (x, y) -> do
44 rec a <- f y -< x
55 b <-
6− g x -<
7− y
8− bar -<
9− ( a,
10− b
11− )
6+ g x
7+ -<
8+ y
9+ bar
10+ -<
11+ ( a,
12+ b
13+ )
1214 rec p <-
1315 f
14− p -<
15− a
16+ p
17+ -<
18+ a
1619 rec q <-
1720 g
18− q -<
19− b
21+ q
22+ -<
23+ b
data/examples/declaration/value/function/awkward-comment-0-out.hsnew file+6
@@ -0,0 +1,6 @@
1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2+mergeErrorReply err1 reply -- XXX where to put it?
3+ =
4+ case reply of
5+ Ok x state err2 -> Ok x state (mergeError err1 err2)
6+ Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-0.hsnew file+5
@@ -0,0 +1,5 @@
1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2+mergeErrorReply err1 reply -- XXX where to put it?
3+ = case reply of
4+ Ok x state err2 -> Ok x state (mergeError err1 err2)
5+ Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-1-out.hsnew file+9
@@ -0,0 +1,9 @@
1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2+doForeign x = x
3+ where
4+ splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits
5+ =
6+ do
7+ let l' = toFDesc l
8+ r' <- irTerm (sMN 0 "__foreignCall") vs env r
9+ return (l', r')
data/examples/declaration/value/function/awkward-comment-1.hsnew file+7
@@ -0,0 +1,7 @@
1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2+doForeign x = x
3+ where
4+ splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
5+ = do let l' = toFDesc l
6+ r' <- irTerm (sMN 0 "__foreignCall") vs env r
7+ return (l', r')
data/examples/declaration/value/function/blank-lines-let-out.hsnew file+6
@@ -0,0 +1,6 @@
1+foo =
2+ let x = 10
3+
4+ y = 11
5+ z = 12
6+ in x + y + z
data/examples/declaration/value/function/blank-lines-let.hsnew file+9
@@ -0,0 +1,9 @@
1+foo =
2+ let
3+
4+ x = 10
5+
6+ y = 11
7+ z = 12
8+
9+ in x + y + z
data/examples/declaration/value/function/blank-lines-where-out.hsnew file+6
@@ -0,0 +1,6 @@
1+foo = x + y + z
2+ where
3+ x = 10
4+
5+ y = 11
6+ z = 12
data/examples/declaration/value/function/blank-lines-where.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = x + y + z
2+ where
3+
4+ x = 10
5+
6+ y = 11
7+ z = 12
data/examples/declaration/value/function/do/blocks-out.hs+1
@@ -15,4 +15,5 @@ readInClause = do
1515 <|> do
1616 optional g_Semi
1717 void allspacing
18+
1819 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 @@
22
33foo = do
44 rec a <- b + 5
5+
56 let d = c
7+
68 b <- a * 5
9+
710 something
11+
812 c <- a + b
913 print c
1014 rec something $ do
1115 x <- a
1216 print x
17+
1318 y <- c
1419 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 @@
11{-# LANGUAGE ImplicitParams #-}
22
33sortBy :: (a -> a -> Bool) -> [a] -> [a]
4+sortBy = undefined
45
56sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
67sort = sortBy ?cmp
data/examples/declaration/value/function/implicit-params.hs+2
@@ -1,6 +1,8 @@
11{-# LANGUAGE ImplicitParams #-}
22sortBy :: (a -> a -> Bool) -> [a] -> [a]
33
4+sortBy = undefined
5+
46sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
57sort = sortBy ?cmp
68
data/examples/declaration/value/function/infix/dollar-chains-out.hs+3−3
@@ -13,9 +13,9 @@ foo =
1313 throwIO (OrmoluCppEnabled path)
1414
1515foo =
16− bar
17− $ baz
18− $ quux
16+ bar $
17+ baz $
18+ quux
1919
2020x =
2121 case l of { A -> B } $
data/examples/declaration/value/function/infix/hanging-out.hs+4−3
@@ -17,6 +17,7 @@ update =
1717 `catch` \case
1818 a -> a
1919
20−foo = bar
21− ++ case foo of
22− a -> a
20+foo =
21+ bar
22+ ++ case foo of
23+ a -> a
data/examples/declaration/value/function/infix/lenses-out.hs+8−7
@@ -1,11 +1,12 @@
11lenses =
2− Just $ M.fromList $
3− "type" .= ("user.connection" :: Text)
4− # "connection" .= uc
5− # "user" .= case name of
6− Just n -> Just $ object ["name" .= n]
7− Nothing -> Nothing
8− # []
2+ Just $
3+ M.fromList $
4+ "type" .= ("user.connection" :: Text)
5+ # "connection" .= uc
6+ # "user" .= case name of
7+ Just n -> Just $ object ["name" .= n]
8+ Nothing -> Nothing
9+ # []
910
1011foo =
1112 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
55foo x = let g :: Int -> Int; g = id in ()
66
77let a = b; c = do { foo; bar }; d = baz in b
8−
98let a = case True of { True -> foo; False -> bar }; b = foo a in b
109
1110foo x = let ?g = id; ?f = g in x
data/examples/declaration/value/function/list-notation-0-out.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ testCase "Foo" testFoo :
3+ testCase "Bar" testBar :
4+ testCase "Baz" testBaz :
5+ []
data/examples/declaration/value/function/list-notation-0.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ testCase "Foo" testFoo :
3+ testCase "Bar" testBar :
4+ testCase "Baz" testBaz :
5+ []
data/examples/declaration/value/function/list-notation-1-out.hsnew file+8
@@ -0,0 +1,8 @@
1+instance A.ToJSON UpdateTable where
2+ toJSON a =
3+ A.object $
4+ "TableName" .= updateTableName a :
5+ "ProvisionedThroughput" .= updateProvisionedThroughput a :
6+ case updateGlobalSecondaryIndexUpdates a of
7+ [] -> []
8+ l -> ["GlobalSecondaryIndexUpdates" .= l]
data/examples/declaration/value/function/list-notation-1.hsnew file+7
@@ -0,0 +1,7 @@
1+instance A.ToJSON UpdateTable where
2+ toJSON a = A.object
3+ $ "TableName" .= updateTableName a
4+ : "ProvisionedThroughput" .= updateProvisionedThroughput a
5+ : case updateGlobalSecondaryIndexUpdates a of
6+ [] -> []
7+ l -> [ "GlobalSecondaryIndexUpdates" .= l ]
data/examples/declaration/value/function/list-notation-2-out.hsnew file+6
@@ -0,0 +1,6 @@
1+-- A list of the element and all its parents up to the root node.
2+getPath tree t =
3+ t :
4+ case Map.lookup (getId t) tree of
5+ Nothing -> []
6+ Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-2.hsnew file+5
@@ -0,0 +1,5 @@
1+-- A list of the element and all its parents up to the root node.
2+getPath tree t = t :
3+ case Map.lookup (getId t) tree of
4+ Nothing -> []
5+ Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-3-out.hsnew file+12
@@ -0,0 +1,12 @@
1+foo =
2+ reportSDoc "tc.cc" 30 $
3+ sep $ do
4+ (prettyTCM q <+> " before compilation") : do
5+ map (prettyTCM . map unArg . clPats) cls
6+
7+foo =
8+ reportSDoc "tc.cc" 30 $
9+ sep $ do
10+ (prettyTCM q <+> " before compilation") :
11+ do
12+ map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/list-notation-3.hsnew file+10
@@ -0,0 +1,10 @@
1+foo =
2+ reportSDoc "tc.cc" 30 $ sep $ do
3+ (prettyTCM q <+> " before compilation") : do
4+ map (prettyTCM . map unArg . clPats) cls
5+
6+foo =
7+ reportSDoc "tc.cc" 30 $ sep $ do
8+ (prettyTCM q <+> " before compilation") :
9+ do
10+ map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/multi-way-if-out.hs+4−2
@@ -3,12 +3,14 @@
33foo x = if | x == 5 -> 5
44
55bar x y =
6− if | x > y -> x
6+ if
7+ | x > y -> x
78 | x < y ->
89 y
910 | otherwise -> x
1011
1112baz =
12− if | p -> f
13+ if
14+ | p -> f
1315 | otherwise -> g
1416 x
data/examples/declaration/value/function/operator-comments-2-out.hsnew file+5
@@ -0,0 +1,5 @@
1+x =
2+ y
3+ ++ f g -- commentA
4+ -- commentB
5+ -- commentC
data/examples/declaration/value/function/operator-comments-2.hsnew file+4
@@ -0,0 +1,4 @@
1+x =
2+ y ++ -- commentA
3+-- commentB
4+ f g -- commentC
data/examples/declaration/value/function/operators-out.hs → data/examples/declaration/value/function/operators-0-out.hsrenamed

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/operators-1-out.hsnew file+4
@@ -0,0 +1,4 @@
1+foo =
2+ f
3+ . g
4+ =<< h . i
data/examples/declaration/value/function/operators-1.hsnew file+3
@@ -0,0 +1,3 @@
1+foo = f
2+ . g
3+ =<< h . i
data/examples/declaration/value/function/operators-2-out.hsnew file+4
@@ -0,0 +1,4 @@
1+foo n
2+ | x || y && z || n ** x
3+ || x && n =
4+ 42
data/examples/declaration/value/function/operators-2.hsnew file+4
@@ -0,0 +1,4 @@
1+foo n
2+ | x || y && z || n ** x
3+ || x && n =
4+ 42
data/examples/declaration/value/function/operators-3-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ op <> n <+> colon <+> prettySe <+> text "="
3+ <+> prettySe <> text sc
data/examples/declaration/value/function/operators-3.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ op <> n <+> colon <+> prettySe <+> text "=" <+>
3+ prettySe <> text sc
data/examples/declaration/value/function/operators-4-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon
3+ <+> align <> prettyPs
data/examples/declaration/value/function/operators-4.hsnew file+3
@@ -0,0 +1,3 @@
1+foo =
2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon <+>
3+ align <> prettyPs
data/examples/declaration/value/function/operators-5-out.hsnew file+5
@@ -0,0 +1,5 @@
1+foo =
2+ map bar $
3+ [ baz
4+ ]
5+ ++ quux
data/examples/declaration/value/function/operators-5.hsnew file+4
@@ -0,0 +1,4 @@
1+foo =
2+ map bar $
3+ [ baz
4+ ] ++ quux
data/examples/declaration/value/function/operators-6-out.hsnew file+9
@@ -0,0 +1,9 @@
1+type PermuteRef =
2+ "a"
3+ :> ( "b" :> "c" :> End
4+ :<|> "c" :> "b" :> End
5+ )
6+ :<|> "b"
7+ :> ( "a" :> "c" :> End
8+ :<|> "c" :> "a" :> End
9+ )
data/examples/declaration/value/function/operators-6.hsnew file+7
@@ -0,0 +1,7 @@
1+type PermuteRef =
2+ "a" :> ( "b" :> "c" :> End
3+ :<|> "c" :> "b" :> End
4+ )
5+ :<|> "b" :> ( "a" :> "c" :> End
6+ :<|> "c" :> "a" :> End
7+ )
data/examples/declaration/value/function/record-constructors-out.hs → data/examples/declaration/value/function/record/constructors-out.hsrenamed

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/record/hanging-after-equal-con-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ Foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-con.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = Foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record/hanging-after-equal-update-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-update.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record-inter-comments-out.hs → data/examples/declaration/value/function/record/inter-comments-out.hsrenamed

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/type-applications-and-splice-out.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [|sing @ $(symFQN name)|]
data/examples/declaration/value/function/type-applications-and-splice.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [| sing @ $(symFQN name) |]
data/examples/import/deduplication-bug-out.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1 (..), Baz1)
2+import Foo2 (Bar2 (..), Baz2)
3+import Foo3 (Bar3 (x1, x2, x3))
4+import Foo4 (Bar4 (x1, x2))
5+import Foo5 (Bar5 (x1))
6+import Foo6 (Bar6 (..))
data/examples/import/deduplication-bug.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1, Baz1, Bar1(..))
2+import Foo2 (Bar2(..), Baz2, Bar2)
3+import Foo3 (Bar3(x1,x3), Bar3(x1, x2))
4+import Foo4 (Bar4(x1), Bar4(x2))
5+import Foo5 (Bar5, Bar5(x1))
6+import Foo6 (Bar6(x1), Bar6(..))
data/examples/import/explicit-imports-out.hs+4−4
@@ -1,12 +1,12 @@
11import qualified MegaModule as M
2− ( (<<<),
3− (>>>),
4− Either,
2+ ( Either,
53 Maybe (Just, Nothing),
64 MaybeT (..),
7− Monad ((>>), (>>=), return),
5+ Monad (return, (>>), (>>=)),
86 MonadBaseControl,
97 join,
108 liftIO,
119 void,
10+ (<<<),
11+ (>>>),
1212 )
data/examples/import/explicit-imports-with-comments-out.hs+3−2
@@ -1,6 +1,7 @@
11import qualified MegaModule as M
22 ( -- (1)
3− (<<<), -- (2)
4− (>>>),
3+ -- (2)
54 Either, -- (3)
5+ (<<<),
6+ (>>>),
67 )
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 @@
11import A hiding
22 ( foobarbazqux,
3− foobarbazqux,
4− foobarbazqux,
5− foobarbazqux,
6− foobarbazqux,
7− foobarbazqux,
8− foobarbazqux,
93 )
104import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)
115import Name hiding ()
data/examples/import/nested-explicit-imports-out.hs+6−6
@@ -1,10 +1,10 @@
11import qualified MegaModule as M
2− ( (<<<),
3− (>>>),
4− Either,
2+ ( Either,
53 Monad
6− ( (>>),
7− (>>=),
8− return
4+ ( return,
5+ (>>),
6+ (>>=)
97 ),
8+ (<<<),
9+ (>>>),
1010 )
data/examples/import/qualified-post-out.hs+1−1
@@ -1,5 +1,5 @@
11{-# LANGUAGE ImportQualifiedPost #-}
22
3−import Data.Text qualified as T
43import Data.Text qualified (a, b, c)
54import Data.Text qualified hiding (a, b, c)
5+import Data.Text qualified as T
data/examples/import/qualified-prelude-out.hs+1−1
@@ -1,4 +1,4 @@
11module P where
22
3+import Prelude hiding (id, (.))
34import qualified Prelude
4−import Prelude hiding ((.), id)
data/examples/import/simple-out.hs+2−3
@@ -1,6 +1,5 @@
11import Data.Text
2−import Data.Text
3−import qualified Data.Text as T
4−import qualified Data.Text (a, b, c)
52import Data.Text (a, b, c)
63import 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
44import qualified Data.Text (a, c, b)
55import Data.Text (a, b, c)
66import 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 @@
11{-# LANGUAGE PatternSynonyms #-}
22
3−module ExportSyntax
4− ( A (.., NoA),
5− Q (F, ..),
6− G (T, .., U),
7− )
8−where
3+module ExportSyntax (A (.., NoA), Q (F, ..), G (T, .., U)) where
94
105data A = A | B
116
data/examples/module-header/multiline2.hs+2−2
@@ -1,2 +1,2 @@
1−module Foo
2− (foo, bar, baz) where
1+module Foo (
2+ foo, bar, baz) where
data/examples/module-header/preceding-comment-with-haddock-out.hs+1−4
@@ -3,9 +3,6 @@
33-}
44
55-- | This is the module's Haddock.
6−module Main
7− ( main,
8− )
9−where
6+module Main (main) where
107
118main = return ()
data/examples/module-header/singleline-empty-out.hs+1−4
@@ -1,5 +1,2 @@
11-- | This demonstrates a BUG.
2−module Foo
3− (
4− )
5−where
2+module Foo () where
data/examples/module-header/stack-header-0-out.hs+1
@@ -3,4 +3,5 @@
33{-# LANGUAGE OverloadedStrings #-}
44
55main = return ()
6+
67-- stack runhaskell
data/examples/module-header/stack-header-1-out.hs+1
@@ -4,4 +4,5 @@
44{-# LANGUAGE OverloadedStrings #-}
55
66main = return ()
7+
78-- stack runhaskell
data/examples/module-header/warning-pragma-multiline-out.hs+1−4
@@ -1,9 +1,6 @@
11module Test
22 {-# DEPRECATED "This module is unstable" #-}
3− ( foo,
4− bar,
5− baz,
6− )
3+ (foo, bar, baz)
74where
85
96import Blah
data/examples/module-header/warning-pragma-out.hs+3−1
@@ -1,3 +1,5 @@
11module Test
2− {-# WARNING "This module is very internal" #-}
2+ {-# WARNING
3+ "This module is very internal"
4+ #-}
35where
data/examples/other/argument-comment-out.hs−1
@@ -9,7 +9,6 @@ foo ::
99 -- | Foo
1010 Int ->
1111 Int
12−
1312foo ::
1413 Foo a =>
1514 -- | Foo
data/examples/other/comment-glued-together-out.hsnew file+7
@@ -0,0 +1,7 @@
1+module Main (main) where
2+
3+-- | Foo.
4+
5+-- Bar
6+main :: IO ()
7+main = return ()
data/examples/other/comment-glued-together.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+{- | Foo. -}
4+-- Bar
5+main :: IO ()
6+main = return ()
data/examples/other/comment-trailing-space-out.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-trailing-space.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-two-blocks-out.hs+2−2
@@ -2,7 +2,7 @@ newNames :: [(String, String)]
22newNames =
33 let (*) = flip (,)
44 in [ "Control" * "Monad"
5− -- Foo
5+ -- Foo
66
7− -- Bar
7+ -- Bar
88 ]
data/examples/other/cpp/continuation-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo :: Int
2+foo = 5
3+
4+#define message_for(a, b) \
5+ printf(#a " and " #b ": We love you!\n")
6+
7+bar :: Int
8+bar = 6
data/examples/other/cpp/continuation.hsnew file+8
@@ -0,0 +1,8 @@
1+foo :: Int
2+foo = 5
3+
4+#define message_for(a, b) \
5+ printf(#a " and " #b ": We love you!\n")
6+
7+bar :: Int
8+bar = 6
data/examples/other/cpp/lonely-hash-out.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+# if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+# endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/lonely-hash.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+# if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+# endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/separation-0a-out.hsnew file+7
@@ -0,0 +1,7 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+
5+#if !(MIN_VERSION_base(4,13,0))
6+ fail = Fail.fail
7+#endif
data/examples/other/cpp/separation-0a.hsnew file+6
@@ -0,0 +1,6 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+#if !(MIN_VERSION_base(4,13,0))
5+ fail = Fail.fail
6+#endif
data/examples/other/cpp/separation-0b-out.hsnew file+10
@@ -0,0 +1,10 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+
5+#if !(MIN_VERSION_base(4,13,0))
6+ fail = Fail.fail
7+#endif
8+
9+foo :: Int
10+foo = undefined
data/examples/other/cpp/separation-0b.hsnew file+9
@@ -0,0 +1,9 @@
1+instance Stream s => Monad (ParsecT e s m) where
2+ return = pure
3+ (>>=) = pBind
4+#if !(MIN_VERSION_base(4,13,0))
5+ fail = Fail.fail
6+#endif
7+
8+foo :: Int
9+foo = undefined
data/examples/other/cpp/separation-1a-out.hsnew file+12
@@ -0,0 +1,12 @@
1+decompressingPipe ::
2+ (PrimMonad m, MonadThrow m, MonadResource m) =>
3+ CompressionMethod ->
4+ ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+
8+#ifdef ENABLE_BZIP2
9+decompressingPipe BZip2 = BZ.bunzip2
10+#else
11+decompressingPipe BZip2 = throwM BZip2Unsupported
12+#endif
data/examples/other/cpp/separation-1a.hsnew file+11
@@ -0,0 +1,11 @@
1+decompressingPipe
2+ :: (PrimMonad m, MonadThrow m, MonadResource m)
3+ => CompressionMethod
4+ -> ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+#ifdef ENABLE_BZIP2
8+decompressingPipe BZip2 = BZ.bunzip2
9+#else
10+decompressingPipe BZip2 = throwM BZip2Unsupported
11+#endif
data/examples/other/cpp/separation-1b-out.hsnew file+15
@@ -0,0 +1,15 @@
1+decompressingPipe ::
2+ (PrimMonad m, MonadThrow m, MonadResource m) =>
3+ CompressionMethod ->
4+ ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+
8+#ifdef ENABLE_BZIP2
9+decompressingPipe BZip2 = BZ.bunzip2
10+#else
11+decompressingPipe BZip2 = throwM BZip2Unsupported
12+#endif
13+
14+foo :: Int
15+foo = undefined
data/examples/other/cpp/separation-1b.hsnew file+14
@@ -0,0 +1,14 @@
1+decompressingPipe
2+ :: (PrimMonad m, MonadThrow m, MonadResource m)
3+ => CompressionMethod
4+ -> ConduitT ByteString ByteString m ()
5+decompressingPipe Store = C.awaitForever C.yield
6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7+#ifdef ENABLE_BZIP2
8+decompressingPipe BZip2 = BZ.bunzip2
9+#else
10+decompressingPipe BZip2 = throwM BZip2Unsupported
11+#endif
12+
13+foo :: Int
14+foo = undefined
data/examples/other/cpp/separation-2a-out.hsnew file+9
@@ -0,0 +1,9 @@
1+ffff, ffffffff :: Natural
2+
3+#ifdef HASKELL_ZIP_DEV_MODE
4+ffff = 200
5+ffffffff = 5000
6+#else
7+ffff = 0xffff
8+ffffffff = 0xffffffff
9+#endif
data/examples/other/cpp/separation-2a.hsnew file+8
@@ -0,0 +1,8 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
data/examples/other/cpp/separation-2b-out.hsnew file+11
@@ -0,0 +1,11 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
9+
10+foo :: Int
11+foo = undefined
data/examples/other/cpp/separation-2b.hsnew file+11
@@ -0,0 +1,11 @@
1+ffff, ffffffff :: Natural
2+#ifdef HASKELL_ZIP_DEV_MODE
3+ffff = 200
4+ffffffff = 5000
5+#else
6+ffff = 0xffff
7+ffffffff = 0xffffffff
8+#endif
9+
10+foo :: Int
11+foo = undefined
data/examples/other/cpp/shifted-out.hsnew file+21
@@ -0,0 +1,21 @@
1+sinkData h compression = do
2+ (uncompressedSize, crc32, compressedSize) <-
3+ case compression of
4+ Store ->
5+ withCompression
6+ dataSink
7+ Deflate ->
8+ withCompression $
9+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink
10+#ifdef ENABLE_BZIP2
11+ BZip2 -> withCompression $
12+ BZ.bzip2 .| dataSink
13+#else
14+ BZip2 -> throwM BZip2Unsupported
15+#endif
16+ return
17+ DataDescriptor
18+ { ddCRC32 = fromIntegral crc32,
19+ ddCompressedSize = compressedSize,
20+ ddUncompressedSize = uncompressedSize
21+ }
data/examples/other/cpp/shifted.hsnew file+17
@@ -0,0 +1,17 @@
1+sinkData h compression = do
2+ (uncompressedSize, crc32, compressedSize) <-
3+ case compression of
4+ Store -> withCompression
5+ dataSink
6+ Deflate -> withCompression $
7+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink
8+#ifdef ENABLE_BZIP2
9+ BZip2 -> withCompression $
10+ BZ.bzip2 .| dataSink
11+#else
12+ BZip2 -> throwM BZip2Unsupported
13+#endif
14+ return DataDescriptor
15+ { ddCRC32 = fromIntegral crc32
16+ , ddCompressedSize = compressedSize
17+ , ddUncompressedSize = uncompressedSize }
data/examples/other/cpp/simple-import-out.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+#if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+#endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/cpp/simple-import.hsnew file+14
@@ -0,0 +1,14 @@
1+module Main (main) where
2+
3+import Data.Void
4+import Test.Hspec
5+import Test.Hspec.Megaparsec
6+import Text.Megaparsec
7+import Text.Megaparsec.Char
8+
9+#if !MIN_VERSION_base(4,13,0)
10+import Data.Semigroup ((<>))
11+#endif
12+
13+main :: IO ()
14+main = return ()
data/examples/other/disabling/indented-fragment-out.hsnew file+7
@@ -0,0 +1,7 @@
1+foo =
2+ {- ORMOLU_DISABLE -}
3+ testCase "Foo" testFoo :
4+ testCase "Bar" testBar :
5+ testCase "Baz" testBaz :
6+ {- ORMOLU_ENABLE -}
7+ []
data/examples/other/disabling/indented-fragment.hsnew file+7
@@ -0,0 +1,7 @@
1+foo =
2+ {- ORMOLU_DISABLE -}
3+ testCase "Foo" testFoo :
4+ testCase "Bar" testBar :
5+ testCase "Baz" testBaz :
6+ {- ORMOLU_ENABLE -}
7+ []
data/examples/other/disabling/single-definition-out.hsnew file+10
@@ -0,0 +1,10 @@
1+module Foo (foo, bar) where
2+
3+{- ORMOLU_DISABLE -}
4+foo :: Int -> Int
5+foo = (+5)
6+{- ORMOLU_ENABLE -}
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/single-definition.hsnew file+10
@@ -0,0 +1,10 @@
1+module Foo (foo,bar) where
2+
3+{- ORMOLU_DISABLE -}
4+foo :: Int -> Int
5+foo = (+5)
6+{- ORMOLU_ENABLE -}
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/whole-file-out.hsnew file+10
@@ -0,0 +1,10 @@
1+{- ORMOLU_DISABLE -}
2+
3+module Foo (foo,bar) where
4+
5+foo :: Int -> Int
6+foo = (+5)
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/disabling/whole-file.hsnew file+10
@@ -0,0 +1,10 @@
1+{- ORMOLU_DISABLE -}
2+
3+module Foo (foo,bar) where
4+
5+foo :: Int -> Int
6+foo = (+5)
7+
8+bar :: Bool -> Bool
9+bar True = True
10+bar False = True
data/examples/other/inline-comment-0-out.hsnew file+3
@@ -0,0 +1,3 @@
1+x = ({-a-} b, c)
2+
3+y = ({-a-} b)
data/examples/other/inline-comment-0.hsnew file+3
@@ -0,0 +1,3 @@
1+x = ({-a-}b, c)
2+
3+y = ({-a-}b)
data/examples/other/inline-comment-1-out.hsnew file+12
@@ -0,0 +1,12 @@
1+showPs env ((n, _, Let _ t v) : bs) =
2+ " " ++ show n ++ " : "
3+ ++ showEnv env ({- normalise ctxt env -} t)
4+ ++ " = "
5+ ++ showEnv env ({- normalise ctxt env -} v)
6+ ++ "\n"
7+ ++ showPs env bs
8+showPs env ((n, _, b) : bs) =
9+ " " ++ show n ++ " : "
10+ ++ showEnv env ({- normalise ctxt env -} (binderTy b))
11+ ++ "\n"
12+ ++ showPs env bs
data/examples/other/inline-comment-1.hsnew file+9
@@ -0,0 +1,9 @@
1+showPs env ((n, _, Let _ t v):bs)
2+ = " " ++ show n ++ " : " ++
3+ showEnv env ({- normalise ctxt env -} t) ++ " = " ++
4+ showEnv env ({- normalise ctxt env -} v) ++
5+ "\n" ++ showPs env bs
6+showPs env ((n, _, b):bs)
7+ = " " ++ show n ++ " : " ++
8+ showEnv env ({- normalise ctxt env -} (binderTy b)) ++
9+ "\n" ++ showPs env bs
data/examples/other/multiline-forall-out.hs+1−2
@@ -12,8 +12,7 @@ data D
1212 )
1313 (x :: *)
1414 (y :: *).
15− D
16− (f x y)
15+ D (f x y)
1716
1817data G where
1918 G ::
data/examples/other/multiple-blank-line-comment-out.hsnew file+9
@@ -0,0 +1,9 @@
1+module A where
2+
3+a =
4+ b
5+ [ f
6+ {-,
7+
8+ -}
9+ ]
data/examples/other/multiple-blank-line-comment.hsnew file+10
@@ -0,0 +1,10 @@
1+module A where
2+
3+a =
4+ b
5+ [ f
6+ {-,
7+
8+
9+ -}
10+ ]
data/examples/other/pragma-comments-after-out.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+-- TODO: Fix and delete this pragma
4+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
data/examples/other/pragma-comments-after.hsnew file+3
@@ -0,0 +1,3 @@
1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- TODO: Fix and delete this pragma
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+{-# LANGUAGE ConstraintKinds #-}
data/examples/other/pragma-comments-out.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+-- TODO This extension is probably too dangerous, remove it.
3+{-# LANGUAGE RecordWildCards #-}
4+-- Avoid warning produced by TH.
5+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
6+
7+-- | Header comment.
8+module Foo () where
data/examples/other/pragma-comments.hsnew file+11
@@ -0,0 +1,11 @@
1+-- | Header comment.
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Avoid warning produced by TH.
6+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
7+
8+-- TODO This extension is probably too dangerous, remove it.
9+{-# LANGUAGE RecordWildCards #-}
10+
11+module Foo () where
data/examples/other/pragma-out.hs+1−4
@@ -9,7 +9,4 @@
99{-# OPTIONS_HADDOCK prune, show-extensions #-}
1010
1111-- | Header comment.
12−module Foo
13− (
14− )
15−where
12+module Foo () where
data/examples/other/pragma-sorting-out.hs+1−2
@@ -1,10 +1,9 @@
11{-# LANGUAGE NondecreasingIndentation #-}
22{-# LANGUAGE ScopedTypeVariables #-}
33{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE NoMonoLocalBinds #-}
5−
64-- This gap is necessary for stylish Haskell not to re-arrange
75-- NoMonoLocalBinds before TypeFamilies
6+{-# LANGUAGE NoMonoLocalBinds #-}
87
98module Foo
109 ( bar,
default.nix+108−61
@@ -1,7 +1,9 @@
1−{ pkgs ? (import ./nix/nixpkgs) }:
1+{ pkgs ? (import ./nix/nixpkgs { inherit system; })
2+, system ? builtins.currentSystem
3+, ormoluCompiler ? "ghc884" # the shell doesn't work with ghc8101 yet
4+}:
25
36let
4− ormoluCompiler = "ghc865";
57 source = pkgs.lib.sourceByRegex ./. [
68 "^.*\.md$"
79 "^app.*$"
@@ -14,67 +16,71 @@ let
1416 overrides = ormoluOverlay;
1517 };
1618 ormoluOverlay = self: super: {
17− "ormolu" = pkgs.haskell.lib.enableCabalFlag
18− (super.callCabal2nix "ormolu" source { }) "dev";
19− # Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want
20− # ghc-lib-parser-8.10.1. We disable Haddock generation because it's way
21− # too slow.
22− "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
23− (super.callHackageDirect {
24− pkg = "ghc-lib-parser";
25− ver = "8.10.1.20200324";
26− sha256 = "0f2c68fzdj2lw6da2zpx7a0cx631im3kylwd85dzx1npsm1vzlbg";
27− } {});
19+ "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };
2820 };
2921 ormolize = import ./nix/ormolize {
3022 inherit pkgs;
3123 inherit haskellPackages;
3224 };
33− # NOTE We have to exclude some directories for some packages because
34− # Ormolu needs files to be parsable by Haddock which is not always the
35− # case. For example some tests and examples do not parse.
36− excludedHackageDirs = {
37− "aws" = ["Examples"];
38− "distributed-process" = ["benchmarks"];
39− "esqueleto" = ["test"];
40− "fay" = ["examples"];
41− "postgrest" = ["test"];
42− };
25+ expectedFailures = [
26+ "Agda"
27+ "aws"
28+ "distributed-process"
29+ "esqueleto"
30+ "fay"
31+ "hlint"
32+ "idris"
33+ "intero"
34+ "leksah"
35+ "pandoc"
36+ "pipes"
37+ "postgrest"
38+ "purescript"
39+ "tensorflow"
40+ ] ++ (if ormoluCompiler == "ghc8101" then [] else ["lens"]);
4341 ormolizedPackages = doCheck:
4442 pkgs.lib.mapAttrs (name: p: ormolize {
4543 package = p;
4644 inherit doCheck;
47− excludedDirs =
48− if builtins.hasAttr name excludedHackageDirs
49− then excludedHackageDirs.${name}
50− else [];
45+ expectedFailures =
46+ if pkgs.lib.lists.any (x: x == name) expectedFailures
47+ then ./expected-failures + "/${name}.txt"
48+ else null;
5149 }) haskellPackages;
5250in {
5351 ormolu = haskellPackages.ormolu;
54− ormoluShell = haskellPackages.shellFor {
55− packages = ps: [
56− ps.ormolu
57− ];
58− buildInputs = [
59− haskellPackages.cabal-install
60− haskellPackages.ghcid
61− ];
62− };
63− withOrmolu = haskellPackages.shellFor {
64− packages = ps: [];
65− buildInputs = [
66− haskellPackages.ormolu
67− ];
52+ # We put the derivations in another attribute set to avoid building them
53+ # when nix-build is run.
54+ dev = {
55+ ormoluShell =
56+ haskellPackages.shellFor {
57+ packages = ps: [
58+ ps.ormolu
59+ ];
60+ buildInputs = [
61+ haskellPackages.cabal-install
62+ haskellPackages.ghcid
63+ ];
64+ };
65+ withOrmolu = haskellPackages.shellFor {
66+ packages = ps: [];
67+ buildInputs = [
68+ haskellPackages.cabal-install
69+ haskellPackages.ormolu
70+ ];
71+ };
6872 };
6973 inherit ormoluOverlay ormoluCompiler;
7074 hackage = ormolizedPackages false;
7175 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
7276 let ps = [
77+ "Agda"
7378 "QuickCheck"
7479 "ShellCheck"
7580 "aeson"
7681 "attoparsec"
7782 "aws"
83+ "brick"
7884 "capability"
7985 "cassava"
8086 "conduit"
@@ -86,37 +92,78 @@ in {
8692 "hakyll"
8793 "haxl"
8894 "hedgehog"
95+ "hledger"
8996 "hlint"
97+ "http-client"
98+ "idris"
99+ "intero"
100+ "leksah"
101+ "lens"
90102 "megaparsec"
91− "ormolu"
92103 "optics"
104+ "ormolu"
105+ "pandoc"
106+ "parsec3"
107+ "pipes"
93108 "postgrest"
109+ "purescript"
94110 "servant"
95111 "servant-server"
112+ "stack"
96113 "tensorflow"
97114 "text_1_2_4_0"
98115 "tls"
99116 "yesod-core"
100−
101− # Comment idempotence issue
102−
103− # "Agda"
104− # "brick"
105− # "hledger"
106− # "http-client"
107− # "idris"
108− # "intero"
109− # "leksah"
110− # "pandoc"
111− # "pipes"
112− # "stack"
113−
114− # Missing language extension
115−
116− # "lens" #fixed in master
117− # "purescript"
118−
119117 ];
120118 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
121119 );
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+ };
122169}
expected-failures/Agda.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17
3+ before: " = (check_ac"
4+ after: " =\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4
9+ before: " nes\n\n "
10+ after: " nes\n\n -- Andreas"
11+Please, consider reporting the bug.
expected-failures/aws.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ Examples/PutBucketNearLine.hs:5:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ Examples/Sqs.hs:(88,3)-(90,4)
7+ parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when
8+ | the program ends as when it started.
9+ -}'
expected-failures/distributed-process.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmarks/Channels.hs:2:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ benchmarks/Spawns.hs:5:1-6
7+ parse error on input `import'
expected-failures/esqueleto.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Database/Esqueleto/Internal/Internal.hs:379:1
3+ lexical error in string/character literal at character 's'
4+
5+The GHC parser (in Haddock mode) failed:
6+ test/PostgreSQL/Test.hs:562:9-41
7+ parse error on input `-- | Check the result is not null'
expected-failures/fay.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ examples/Separated.hs:12:1-6
3+ parse error on input `module'
4+
5+The GHC parser (in Haddock mode) failed:
6+ examples/calc.hs:(4,1)-(6,2)
7+ parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs
8+-- You also need to download jquery.min.js.
9+--'
10+
11+The GHC parser (in Haddock mode) failed:
12+ examples/canvaswater.hs:(6,1)-(7,17)
13+ parse error on input `-- | A demonstration of Fay using the canvas element to display a
14+-- simple effect.'
15+
16+The GHC parser (in Haddock mode) failed:
17+ examples/data.hs:9:1-6
18+ parse error on input `module'
expected-failures/hlint.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ src/Extension.hs<rendered>:19:22
3+ before: "DoRec , -} Recursive"
4+ after: "DoRec , -}\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/Hint/Bracket.hs<rendered>:249:50
9+ before: "\" x y [r]) {ideaSpan"
10+ after: "\" x y [r])\n "
11+Please, consider reporting the bug.
expected-failures/idris.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Idris/Parser.hs:1052:1
3+ parse error on input `@'
4+
5+The GHC parser (in Haddock mode) failed:
6+ src/Idris/Parser/Expr.hs:75:1
7+ parse error on input `@'
expected-failures/intero.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/InteractiveUI.hs<rendered>:3748:33
3+ before: "text \"Try\" <+> doWha"
4+ after: "text \"Try\"\n "
5+Please, consider reporting the bug.
expected-failures/leksah.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/IDE/Pane/Modules.hs<rendered>:1184:7
3+ before: "cr\n -- show"
4+ after: "cr\n in -- show"
5+Please, consider reporting the bug.
expected-failures/lens.txtnew file+3
@@ -0,0 +1,3 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Control/Exception/Lens.hs:180:13-37
3+ parse error on input `AllocationLimitExceeded__'
expected-failures/pandoc.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmark/weigh-pandoc.hs:14:1-6
3+ parse error on input `import'
4+
5+Formatting is not idempotent:
6+ src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:613:19
7+ before: ".softbreak <$ endlin"
8+ after: ".softbreak\n <$ en"
9+Please, consider reporting the bug.
expected-failures/pipes.txtnew file+3
@@ -0,0 +1,3 @@
1+AST of input and AST of formatted code differ.
2+ at src/Pipes/Core.hs:(128,1)-(151,2)
3+Please, consider reporting the bug.
expected-failures/postgrest.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/PostgREST/DbRequestBuilder.hs<rendered>:149:24
3+ before: " || -- clients"
4+ after: " || ( origin ="
5+Please, consider reporting the bug.
expected-failures/purescript.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Language/PureScript/AST/Declarations.hs:479:1-17
3+ Invalid type signature: pattern ValueDecl :: ...
4+Perhaps you meant to use PatternSynonyms?
5+
6+The GHC parser (in Haddock mode) failed:
7+ src/Language/PureScript/AST/SourcePos.hs:99:1-22
8+ Invalid type signature: pattern NullSourceSpan :: ...
9+Perhaps you meant to use PatternSynonyms?
10+
11+The GHC parser (in Haddock mode) failed:
12+ src/Language/PureScript/Constants.hs:42:1-15
13+ Invalid type signature: pattern Discard :: ...
14+Perhaps you meant to use PatternSynonyms?
15+
16+The GHC parser (in Haddock mode) failed:
17+ src/Language/PureScript/Crash.hs:16:1-6
18+ parse error on input `import'
expected-failures/tensorflow.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ tensorflow-mnist/app/Main.hs:50:13-14
3+ parse error on input `->'
4+
5+The GHC parser (in Haddock mode) failed:
6+ tensorflow-ops/tests/RegressionTest.hs:3:1-6
7+ parse error on input `import'
format.sh+6−4
@@ -1,5 +1,5 @@
11#!/usr/bin/env nix-shell
2−#!nix-shell default.nix -A withOrmolu -i bash --pure
2+#!nix-shell default.nix -A dev.withOrmolu -i bash --pure
33#
44# Format Ormolu using current version of Ormolu.
55
@@ -7,6 +7,8 @@ set -e
77
88export LANG="C.UTF-8"
99
10−ormolu -p -m inplace $(find app -type f -name "*.hs")
11−ormolu -p -m inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
12−ormolu -p -m inplace $(find tests -type f -name "*.hs")
10+cabal format
11+
12+ormolu -m inplace $(find app -type f -name "*.hs")
13+ormolu -m inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
14+ormolu -m inplace $(find tests -type f -name "*.hs")
nix/nixpkgs/default.nix+7−3
@@ -1,9 +1,13 @@
1+{ system ? builtins.currentSystem }:
12let
2− rev = "19.09";
3− sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";
3+ rev = "32b46dd897ab2143a609988a04d87452f0bbef59";
4+ sha256 = "1gzfrpjnr1bz9zljsyg3a4zrhk8r927sz761mrgcg56dwinkhpjk";
45 nixpkgs = builtins.fetchTarball {
56 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
67 inherit sha256;
78 };
8− pkgs = import nixpkgs { config.allowUnfree = true; };
9+ pkgs = import nixpkgs {
10+ inherit system;
11+ config.allowUnfree = true;
12+ };
913in pkgs
nix/ormolize/default.nix+29−13
@@ -2,32 +2,48 @@
22, haskellPackages
33}:
44{ package
5+, expectedFailures ? null
56, doCheck ? false
6−, excludedDirs ? []
77}:
88 pkgs.stdenv.mkDerivation rec {
99 name = package.name + "-ormolized";
1010 src = package.src;
1111 buildInputs = [
1212 haskellPackages.cpphs
13− (if doCheck
14− then haskellPackages.ormolu
15− else pkgs.haskell.lib.dontCheck haskellPackages.ormolu)
13+ haskellPackages.ormolu
14+ pkgs.diffutils
1615 pkgs.glibcLocales
1716 ];
1817 LANG = "en_US.UTF-8";
19− excludedDirsRendered =
20− if excludedDirs == []
21− then ""
22− else pkgs.lib.concatMapStringsSep " " (x: "-not -path './" + x + "/*'") excludedDirs;
2318 buildPhase = ''
24− find . -name '*.hs' ${excludedDirsRendered} -exec bash ${./ormolize.sh} {} \; 2> log.txt
25− cat log.txt
19+ hs_files=$(find . -name '*.hs')
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
2636 '';
2737 inherit doCheck;
28− checkPhase = ''
29− if [[ -s log.txt ]]; then exit 1; fi
30− '';
38+ checkPhase =
39+ if expectedFailures == null
40+ then ''
41+ echo "No failures expected"
42+ if [[ -s log.txt ]]; then exit 1; fi
43+ ''
44+ else ''
45+ diff --ignore-blank-lines --color=always ${expectedFailures} log.txt
46+ '';
3147 installPhase = ''
3248 mkdir "$out"
3349 find . -name '*.hs-original' -exec cp --parents {} $out \;
nix/ormolize/ormolize.shdeleted−17
@@ -1,17 +0,0 @@
1−set -euo pipefail
2−
3−# drop includes
4−sed -i '/^#include/d' "$1"
5−
6−# deal with CPP in a fairly straightforward way
7−cpphs "$1" --noline > "$1-nocpp" 2> /dev/null
8−
9−# annoyingly, cpphs cannot modify files in place
10−mv "$1-nocpp" "$1"
11−
12−# preserve the original
13−cp "$1" "$1-original"
14−
15−# run ormolu
16−ormolu --tolerate-cpp --check-idempotency --mode inplace "$1" ||
17− ormolu --tolerate-cpp --unsafe --mode inplace "$1"
ormolu.cabal+174−155
@@ -1,165 +1,184 @@
1−name: ormolu
2−version: 0.0.3.1
3−cabal-version: 1.18
4−tested-with: GHC==8.6.5
5−license: BSD3
6−license-file: LICENSE.md
7−maintainer: Mark Karpov <mark.karpov@tweag.io>
8−homepage: https://github.com/tweag/ormolu
9−bug-reports: https://github.com/tweag/ormolu/issues
10−category: Development, Formatting
11−synopsis: A formatter for Haskell source code
12−build-type: Simple
13−description: A formatter for Haskell source code.
14−extra-doc-files: CONTRIBUTING.md
15− , CHANGELOG.md
16− , DESIGN.md
17− , README.md
18−data-files: data/examples/declaration/annotation/*.hs
19− , data/examples/declaration/class/*.hs
20− , data/examples/declaration/data/*.hs
21− , data/examples/declaration/data/gadt/*.hs
22− , data/examples/declaration/default/*.hs
23− , data/examples/declaration/deriving/*.hs
24− , data/examples/declaration/foreign/*.hs
25− , data/examples/declaration/instance/*.hs
26− , data/examples/declaration/rewrite-rule/*.hs
27− , data/examples/declaration/role-annotation/*.hs
28− , data/examples/declaration/signature/complete/*.hs
29− , data/examples/declaration/signature/fixity/*.hs
30− , data/examples/declaration/signature/inline/*.hs
31− , data/examples/declaration/signature/minimal/*.hs
32− , data/examples/declaration/signature/pattern/*.hs
33− , data/examples/declaration/signature/set-cost-centre/*.hs
34− , data/examples/declaration/signature/specialize/*.hs
35− , data/examples/declaration/signature/type/*.hs
36− , data/examples/declaration/splice/*.hs
37− , data/examples/declaration/type-families/closed-type-family/*.hs
38− , data/examples/declaration/type-families/data-family/*.hs
39− , data/examples/declaration/type-families/type-family/*.hs
40− , data/examples/declaration/type-synonyms/*.hs
41− , data/examples/declaration/type/*.hs
42− , data/examples/declaration/value/function/*.hs
43− , data/examples/declaration/value/function/arrow/*.hs
44− , data/examples/declaration/value/function/comprehension/*.hs
45− , data/examples/declaration/value/function/do/*.hs
46− , data/examples/declaration/value/function/infix/*.hs
47− , data/examples/declaration/value/function/pattern/*.hs
48− , data/examples/declaration/value/other/*.hs
49− , data/examples/declaration/value/pattern-synonyms/*.hs
50− , data/examples/declaration/warning/*.hs
51− , data/examples/import/*.hs
52− , data/examples/module-header/*.hs
53− , data/examples/other/*.hs
1+cabal-version: 1.18
2+name: ormolu
3+version: 0.1.2.0
4+license: BSD3
5+license-file: LICENSE.md
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
9+bug-reports: https://github.com/tweag/ormolu/issues
10+synopsis: A formatter for Haskell source code
11+description: A formatter for Haskell source code.
12+category: Development, Formatting
13+build-type: Simple
14+data-files:
15+ data/examples/declaration/annotation/*.hs
16+ data/examples/declaration/class/*.hs
17+ data/examples/declaration/data/*.hs
18+ data/examples/declaration/data/gadt/*.hs
19+ data/examples/declaration/default/*.hs
20+ data/examples/declaration/deriving/*.hs
21+ data/examples/declaration/foreign/*.hs
22+ data/examples/declaration/instance/*.hs
23+ data/examples/declaration/rewrite-rule/*.hs
24+ data/examples/declaration/role-annotation/*.hs
25+ data/examples/declaration/signature/complete/*.hs
26+ data/examples/declaration/signature/fixity/*.hs
27+ data/examples/declaration/signature/inline/*.hs
28+ data/examples/declaration/signature/minimal/*.hs
29+ data/examples/declaration/signature/pattern/*.hs
30+ data/examples/declaration/signature/set-cost-centre/*.hs
31+ data/examples/declaration/signature/specialize/*.hs
32+ data/examples/declaration/signature/type/*.hs
33+ data/examples/declaration/splice/*.hs
34+ data/examples/declaration/type-families/closed-type-family/*.hs
35+ data/examples/declaration/type-families/data-family/*.hs
36+ data/examples/declaration/type-families/type-family/*.hs
37+ data/examples/declaration/type-synonyms/*.hs
38+ data/examples/declaration/type/*.hs
39+ data/examples/declaration/value/function/*.hs
40+ data/examples/declaration/value/function/arrow/*.hs
41+ data/examples/declaration/value/function/comprehension/*.hs
42+ data/examples/declaration/value/function/do/*.hs
43+ data/examples/declaration/value/function/infix/*.hs
44+ data/examples/declaration/value/function/pattern/*.hs
45+ data/examples/declaration/value/other/*.hs
46+ data/examples/declaration/value/pattern-synonyms/*.hs
47+ data/examples/declaration/warning/*.hs
48+ data/examples/import/*.hs
49+ data/examples/module-header/*.hs
50+ data/examples/other/*.hs
51+
52+extra-doc-files:
53+ CONTRIBUTING.md
54+ CHANGELOG.md
55+ DESIGN.md
56+ README.md
5457
5558source-repository head
56− type: git
57− location: https://github.com/tweag/ormolu.git
59+ type: git
60+ location: https://github.com/tweag/ormolu.git
5861
5962flag dev
60− description: Turn on development settings.
61− manual: True
62− default: False
63+ description: Turn on development settings.
64+ default: False
65+ manual: True
6366
6467library
65− hs-source-dirs: src
66− build-depends: base >= 4.12 && < 5.0
67− , bytestring >= 0.2 && < 0.11
68− , containers >= 0.5 && < 0.7
69− , dlist >= 0.8 && < 0.9
70− , exceptions >= 0.6 && < 0.11
71− , ghc-lib-parser >= 8.10 && < 8.11
72− , mtl >= 2.0 && < 3.0
73− , syb >= 0.7 && < 0.8
74− , text >= 0.2 && < 1.3
75− exposed-modules: Ormolu
76− , Ormolu.Config
77− , Ormolu.Diff
78− , Ormolu.Exception
79− , Ormolu.Imports
80− , Ormolu.Parser
81− , Ormolu.Parser.Anns
82− , Ormolu.Parser.CommentStream
83− , Ormolu.Parser.Pragma
84− , Ormolu.Parser.Result
85− , Ormolu.Printer
86− , Ormolu.Printer.Combinators
87− , Ormolu.Printer.Comments
88− , Ormolu.Printer.Internal
89− , Ormolu.Printer.Meat.Common
90− , Ormolu.Printer.Meat.Declaration
91− , Ormolu.Printer.Meat.Declaration.Annotation
92− , Ormolu.Printer.Meat.Declaration.Class
93− , Ormolu.Printer.Meat.Declaration.Data
94− , Ormolu.Printer.Meat.Declaration.Default
95− , Ormolu.Printer.Meat.Declaration.Foreign
96− , Ormolu.Printer.Meat.Declaration.Instance
97− , Ormolu.Printer.Meat.Declaration.RoleAnnotation
98− , Ormolu.Printer.Meat.Declaration.Rule
99− , Ormolu.Printer.Meat.Declaration.Signature
100− , Ormolu.Printer.Meat.Declaration.Splice
101− , Ormolu.Printer.Meat.Declaration.Type
102− , Ormolu.Printer.Meat.Declaration.TypeFamily
103− , Ormolu.Printer.Meat.Declaration.Value
104− , Ormolu.Printer.Meat.Declaration.Warning
105− , Ormolu.Printer.Meat.ImportExport
106− , Ormolu.Printer.Meat.Module
107− , Ormolu.Printer.Meat.Pragma
108− , Ormolu.Printer.Meat.Type
109− , Ormolu.Printer.Operators
110− , Ormolu.Printer.SpanStream
111− , Ormolu.Utils
112− other-modules: GHC
113− , GHC.DynFlags
114− if flag(dev)
115− ghc-options: -Wall -Werror -Wcompat
116− -Wincomplete-record-updates
117− -Wincomplete-uni-patterns
118− -Wnoncanonical-monad-instances
119− -- https://github.com/haskell/haddock/issues/1116
120− -Wno-missing-home-modules
121− else
122− ghc-options: -O2 -Wall
123− default-language: Haskell2010
68+ exposed-modules:
69+ Ormolu
70+ Ormolu.Config
71+ Ormolu.Diff
72+ Ormolu.Exception
73+ Ormolu.Imports
74+ Ormolu.Parser
75+ Ormolu.Parser.Anns
76+ Ormolu.Parser.CommentStream
77+ Ormolu.Parser.Pragma
78+ Ormolu.Parser.Result
79+ Ormolu.Parser.Shebang
80+ Ormolu.Printer
81+ Ormolu.Printer.Combinators
82+ Ormolu.Printer.Comments
83+ Ormolu.Printer.Internal
84+ Ormolu.Printer.Meat.Common
85+ Ormolu.Printer.Meat.Declaration
86+ Ormolu.Printer.Meat.Declaration.Annotation
87+ Ormolu.Printer.Meat.Declaration.Class
88+ Ormolu.Printer.Meat.Declaration.Data
89+ Ormolu.Printer.Meat.Declaration.Default
90+ Ormolu.Printer.Meat.Declaration.Foreign
91+ Ormolu.Printer.Meat.Declaration.Instance
92+ Ormolu.Printer.Meat.Declaration.RoleAnnotation
93+ Ormolu.Printer.Meat.Declaration.Rule
94+ Ormolu.Printer.Meat.Declaration.Signature
95+ Ormolu.Printer.Meat.Declaration.Splice
96+ Ormolu.Printer.Meat.Declaration.Type
97+ Ormolu.Printer.Meat.Declaration.TypeFamily
98+ Ormolu.Printer.Meat.Declaration.Value
99+ Ormolu.Printer.Meat.Declaration.Warning
100+ Ormolu.Printer.Meat.ImportExport
101+ Ormolu.Printer.Meat.Module
102+ Ormolu.Printer.Meat.Pragma
103+ Ormolu.Printer.Meat.Type
104+ Ormolu.Printer.Operators
105+ Ormolu.Printer.SpanStream
106+ Ormolu.Processing.Common
107+ Ormolu.Processing.Cpp
108+ Ormolu.Processing.Postprocess
109+ Ormolu.Processing.Preprocess
110+ Ormolu.Utils
124111
125−test-suite tests
126− main-is: Spec.hs
127− hs-source-dirs: tests
128− type: exitcode-stdio-1.0
129− build-depends: base >= 4.12 && < 5.0
130− , containers >= 0.5 && < 0.7
131− , filepath >= 1.2 && < 1.5
132− , hspec >= 2.0 && < 3.0
133− , ormolu
134− , path >= 0.6 && < 0.8
135− , path-io >= 1.4.2 && < 2.0
136− , text >= 0.2 && < 1.3
137− build-tools: hspec-discover >= 2.0 && < 3.0
138− other-modules:
139− Ormolu.Parser.PragmaSpec
140− , Ormolu.PrinterSpec
112+ hs-source-dirs: src
113+ other-modules:
114+ GHC
115+ GHC.DynFlags
116+
117+ default-language: Haskell2010
118+ build-depends:
119+ base >=4.12 && <5.0,
120+ bytestring >=0.2 && <0.11,
121+ containers >=0.5 && <0.7,
122+ dlist >=0.8 && <2.0,
123+ exceptions >=0.6 && <0.11,
124+ ghc-lib-parser >=8.10 && <8.11,
125+ mtl >=2.0 && <3.0,
126+ syb >=0.7 && <0.8,
127+ text >=0.2 && <1.3
141128
142− if flag(dev)
143− ghc-options: -Wall -Werror
144− else
145− ghc-options: -O2 -Wall
146− default-language: Haskell2010
129+ if flag(dev)
130+ ghc-options:
131+ -Wall -Werror -Wcompat -Wincomplete-record-updates
132+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances
133+ -Wno-missing-home-modules
134+
135+ else
136+ ghc-options: -O2 -Wall
147137
148138executable ormolu
149− main-is: Main.hs
150− hs-source-dirs: app
151− build-depends: base >= 4.12 && < 5.0
152− , ghc-lib-parser >= 8.10 && < 8.11
153− , gitrev >= 1.3 && < 1.4
154− , optparse-applicative >= 0.14 && < 0.16
155− , ormolu
156− , text >= 0.2 && < 1.3
157− other-modules: Paths_ormolu
158− if flag(dev)
159− ghc-options: -Wall -Werror -Wcompat
160− -Wincomplete-record-updates
161− -Wincomplete-uni-patterns
162− -Wnoncanonical-monad-instances
163− else
164− ghc-options: -O2 -Wall -rtsopts
165− default-language: Haskell2010
139+ main-is: Main.hs
140+ hs-source-dirs: app
141+ other-modules: Paths_ormolu
142+ default-language: Haskell2010
143+ build-depends:
144+ base >=4.12 && <5.0,
145+ ghc-lib-parser >=8.10 && <8.11,
146+ gitrev >=1.3 && <1.4,
147+ optparse-applicative >=0.14 && <0.17,
148+ ormolu -any,
149+ text >=0.2 && <1.3
150+
151+ if flag(dev)
152+ ghc-options:
153+ -Wall -Werror -Wcompat -Wincomplete-record-updates
154+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances
155+ -optP-Wno-nonportable-include-path
156+
157+ else
158+ ghc-options: -O2 -Wall -rtsopts
159+
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+
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+}:
24
3−(import ./default.nix { inherit pkgs; }).ormoluShell
5+(import ./default.nix { inherit pkgs; }).dev.ormoluShell
src/GHC.hs−3
@@ -1,6 +1,5 @@
11module GHC
22 ( module X,
3− ParsedSource,
43 )
54where
65
@@ -11,5 +10,3 @@ import GHC.Hs.Instances as X ()
1110import Module as X
1211import RdrName as X
1312import SrcLoc as X
14−
15−type ParsedSource = Located (HsModule GhcPs)
src/Ormolu.hs+10−7
@@ -6,6 +6,7 @@ module Ormolu
66 ormoluFile,
77 ormoluStdin,
88 Config (..),
9+ RegionIndices (..),
910 defaultConfig,
1011 DynOption (..),
1112 OrmoluException (..),
@@ -42,13 +43,15 @@ import qualified SrcLoc as GHC
4243ormolu ::
4344 MonadIO m =>
4445 -- | Ormolu configuration
45− Config ->
46+ Config RegionIndices ->
4647 -- | Location of source file
4748 FilePath ->
4849 -- | Input to format
4950 String ->
5051 m Text
51−ormolu cfg path str = do
52+ormolu cfgWithIndices path str = do
53+ let totalLines = length (lines str)
54+ cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices
5255 (warnings, result0) <-
5356 parseModule' cfg OrmoluParsingFailed path str
5457 when (cfgDebug cfg) $ do
@@ -60,7 +63,7 @@ ormolu cfg path str = do
6063 -- to parse the rendered code back, inside of GHC monad wrapper which will
6164 -- lead to error messages presenting the exceptions as GHC bugs.
6265 let !txt = printModule result0
63− when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do
66+ when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do
6467 let pathRendered = path ++ "<rendered>"
6568 -- Parse the result of pretty-printing again and make sure that AST
6669 -- is the same as AST of original snippet module span positions.
@@ -76,7 +79,7 @@ ormolu cfg path str = do
7679 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)
7780 -- Try re-formatting the formatted result to check if we get exactly
7881 -- the same output.
79− when (cfgCheckIdempotency cfg) $
82+ when (cfgCheckIdempotence cfg) $
8083 let txt2 = printModule result1
8184 in case diffText txt txt2 pathRendered of
8285 Nothing -> return ()
@@ -93,7 +96,7 @@ ormolu cfg path str = do
9396ormoluFile ::
9497 MonadIO m =>
9598 -- | Ormolu configuration
96− Config ->
99+ Config RegionIndices ->
97100 -- | Location of source file
98101 FilePath ->
99102 -- | Resulting rendition
@@ -108,7 +111,7 @@ ormoluFile cfg path =
108111ormoluStdin ::
109112 MonadIO m =>
110113 -- | Ormolu configuration
111− Config ->
114+ Config RegionIndices ->
112115 -- | Resulting rendition
113116 m Text
114117ormoluStdin cfg =
@@ -121,7 +124,7 @@ ormoluStdin cfg =
121124parseModule' ::
122125 MonadIO m =>
123126 -- | Ormolu configuration
124− Config ->
127+ Config RegionDeltas ->
125128 -- | How to obtain 'OrmoluException' to throw when parsing fails
126129 (GHC.SrcSpan -> String -> OrmoluException) ->
127130 -- | File name to use in errors
src/Ormolu/Config.hs+62−23
@@ -1,7 +1,13 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE RecordWildCards #-}
3+
14-- | Configuration options used by the tool.
25module Ormolu.Config
36 ( Config (..),
7+ RegionIndices (..),
8+ RegionDeltas (..),
49 defaultConfig,
10+ regionIndicesToDeltas,
511 DynOption (..),
612 dynOptionToLocatedStr,
713 )
@@ -10,39 +16,72 @@ where
1016import qualified SrcLoc as GHC
1117
1218-- | Ormolu configuration.
13−data Config
14− = Config
15− { -- | Dynamic options to pass to GHC parser
16− cfgDynOptions :: ![DynOption],
17− -- | Do formatting faster but without automatic detection of defects
18− cfgUnsafe :: !Bool,
19− -- | Output information useful for debugging
20− cfgDebug :: !Bool,
21− -- | Do not fail if CPP pragma is present (still doesn't handle CPP but
22− -- useful for formatting of files that enable the extension without
23− -- actually containing CPP macros)
24− cfgTolerateCpp :: !Bool,
25− -- | Checks if re-formatting the result is idempotent.
26− cfgCheckIdempotency :: !Bool
27− }
19+data Config region = Config
20+ { -- | Dynamic options to pass to GHC parser
21+ cfgDynOptions :: ![DynOption],
22+ -- | Do formatting faster but without automatic detection of defects
23+ cfgUnsafe :: !Bool,
24+ -- | Output information useful for debugging
25+ cfgDebug :: !Bool,
26+ -- | Checks if re-formatting the result is idempotent
27+ cfgCheckIdempotence :: !Bool,
28+ -- | Region selection
29+ cfgRegion :: !region
30+ }
31+ deriving (Eq, Show, Functor)
32+
33+-- | Region selection as the combination of start and end line numbers.
34+data RegionIndices = RegionIndices
35+ { -- | Start line of the region to format
36+ regionStartLine :: !(Maybe Int),
37+ -- | End line of the region to format
38+ regionEndLine :: !(Maybe Int)
39+ }
40+ deriving (Eq, Show)
41+
42+-- | Region selection as the length of the literal prefix and the literal
43+-- suffix.
44+data RegionDeltas = RegionDeltas
45+ { -- | Prefix length in number of lines
46+ regionPrefixLength :: !Int,
47+ -- | Suffix length in number of lines
48+ regionSuffixLength :: !Int
49+ }
2850 deriving (Eq, Show)
2951
30−-- | Default 'Config'.
31−defaultConfig :: Config
52+-- | Default @'Config' 'RegionIndices'@.
53+defaultConfig :: Config RegionIndices
3254defaultConfig =
3355 Config
3456 { cfgDynOptions = [],
3557 cfgUnsafe = False,
3658 cfgDebug = False,
37− cfgTolerateCpp = False,
38− cfgCheckIdempotency = 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
3979 }
4080
4181-- | A wrapper for dynamic options.
42−newtype DynOption
43− = DynOption
44− { unDynOption :: String
45− }
82+newtype DynOption = DynOption
83+ { unDynOption :: String
84+ }
4685 deriving (Eq, Ord, Show)
4786
4887-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
src/Ormolu/Diff.hs+15−12
@@ -14,7 +14,8 @@ import Data.Text (Text)
1414import qualified Data.Text as T
1515import qualified FastString as GHC
1616import GHC
17−import Ormolu.Imports (sortImports)
17+import Ormolu.Imports (normalizeImports)
18+import Ormolu.Parser.CommentStream
1819import Ormolu.Parser.Result
1920import Ormolu.Utils
2021
@@ -38,14 +39,16 @@ diffParseResult :: ParseResult -> ParseResult -> Diff
3839diffParseResult
3940 ParseResult
4041 { prCommentStream = cstream0,
41− prParsedSource = ps0
42+ prParsedSource = hs0
4243 }
4344 ParseResult
4445 { prCommentStream = cstream1,
45− prParsedSource = ps1
46+ prParsedSource = hs1
4647 } =
4748 matchIgnoringSrcSpans cstream0 cstream1
48− <> matchIgnoringSrcSpans ps0 ps1
49+ <> matchIgnoringSrcSpans
50+ hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}
51+ hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}
4952
5053-- | Compare two values for equality disregarding differences in 'SrcSpan's
5154-- and the ordering of import lists.
@@ -67,7 +70,7 @@ matchIgnoringSrcSpans = genericQuery
6770 gzipWithQ
6871 ( genericQuery
6972 `extQ` srcSpanEq
70− `extQ` hsModuleEq
73+ `extQ` commentEq
7174 `extQ` sourceTextEq
7275 `extQ` hsDocStringEq
7376 `extQ` importDeclQualifiedStyleEq
@@ -78,14 +81,14 @@ matchIgnoringSrcSpans = genericQuery
7881 | otherwise = Different []
7982 srcSpanEq :: SrcSpan -> GenericQ Diff
8083 srcSpanEq _ _ = Same
81− hsModuleEq :: HsModule GhcPs -> GenericQ Diff
82− hsModuleEq hs0 hs1' =
83− case cast hs1' :: Maybe (HsModule GhcPs) of
84+ commentEq :: Comment -> GenericQ Diff
85+ commentEq (Comment _ x) d =
86+ case cast d :: Maybe Comment of
8487 Nothing -> Different []
85− Just hs1 ->
86− matchIgnoringSrcSpans
87− hs0 {hsmodImports = sortImports (hsmodImports hs0)}
88− hs1 {hsmodImports = sortImports (hsmodImports hs1)}
88+ Just (Comment _ y) ->
89+ if x == y
90+ then Same
91+ else Different []
8992 sourceTextEq :: SourceText -> GenericQ Diff
9093 sourceTextEq _ _ = Same
9194 importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff
src/Ormolu/Exception.hs+4−11
@@ -19,9 +19,7 @@ import System.IO
1919
2020-- | Ormolu exception representing all cases when Ormolu can fail.
2121data OrmoluException
22− = -- | Ormolu does not work with source files that use CPP
23− OrmoluCppEnabled FilePath
24− | -- | Parsing of original source code failed
22+ = -- | Parsing of original source code failed
2523 OrmoluParsingFailed GHC.SrcSpan String
2624 | -- | Parsing of formatted source code failed
2725 OrmoluOutputParsingFailed GHC.SrcSpan String
@@ -35,13 +33,8 @@ data OrmoluException
3533
3634instance Exception OrmoluException where
3735 displayException = \case
38− OrmoluCppEnabled path ->
39− unlines
40− [ "CPP is not supported:",
41− withIndent path
42− ]
4336 OrmoluParsingFailed s e ->
44− showParsingErr "Parsing of source code failed:" s [e]
37+ showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]
4538 OrmoluOutputParsingFailed s e ->
4639 showParsingErr "Parsing of formatted code failed:" s [e]
4740 ++ "Please, consider reporting the bug.\n"
@@ -81,8 +74,8 @@ withPrettyOrmoluExceptions m = m `catch` h
8174 hPutStrLn stderr (displayException e)
8275 exitWith . ExitFailure $
8376 case e of
84− -- Error code 1 is for `error` or `notImplemented`
85− OrmoluCppEnabled {} -> 2
77+ -- Error code 1 is for 'error' or 'notImplemented'
78+ -- 2 used to be for erroring out on CPP
8679 OrmoluParsingFailed {} -> 3
8780 OrmoluOutputParsingFailed {} -> 4
8881 OrmoluASTDiffers {} -> 5
src/Ormolu/Imports.hs+161−44
@@ -4,82 +4,199 @@
44
55-- | Manipulations on import lists.
66module Ormolu.Imports
7− ( sortImports,
7+ ( normalizeImports,
88 )
99where
1010
1111import Data.Bifunctor
12+import Data.Char (isAlphaNum)
1213import Data.Function (on)
13−import Data.Generics (gcompare)
14−import Data.List (sortBy)
14+import Data.List (foldl', nubBy, sortBy, sortOn)
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
17+import FastString (FastString)
1518import GHC hiding (GhcPs, IE)
1619import GHC.Hs.Extension
1720import GHC.Hs.ImpExp (IE (..))
18−import Ormolu.Utils (notImplemented)
21+import Ormolu.Utils (notImplemented, showOutputable)
1922
20−-- | Sort imports by module name. This also sorts explicit import lists for
21−-- each declaration.
22−sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
23−sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
23+-- | Sort and normalize imports.
24+normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
25+normalizeImports =
26+ fmap snd
27+ . M.toAscList
28+ . M.fromListWith combineImports
29+ . fmap (\x -> (importId x, g x))
2430 where
25− sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
26− sortImportLists = \case
27− ImportDecl {..} ->
31+ g (L l ImportDecl {..}) =
32+ L
33+ l
2834 ImportDecl
29− { ideclHiding = second (fmap sortLies) <$> ideclHiding,
35+ { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,
3036 ..
3137 }
32− XImportDecl x -> noExtCon x
38+ g _ = notImplemented "XImportDecl"
3339
34−-- | Compare two @'LImportDecl' 'GhcPs'@ things.
35−compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
36−compareIdecl (L _ m0) (L _ m1) =
37− case (isPrelude n0, isPrelude n1) of
38− (False, False) -> n0 `compare` n1
39− (True, False) -> GT
40− (False, True) -> LT
41− (True, True) -> m0 `gcompare` m1
40+-- | Combine two import declarations. It should be assumed that 'ImportId's
41+-- are equal.
42+combineImports ::
43+ LImportDecl GhcPs ->
44+ LImportDecl GhcPs ->
45+ LImportDecl GhcPs
46+combineImports (L lx ImportDecl {..}) (L _ y) =
47+ L
48+ lx
49+ ImportDecl
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+ }
4291 where
43− n0 = unLoc (ideclName m0)
44− n1 = unLoc (ideclName m1)
45− isPrelude = (== "Prelude") . moduleNameString
92+ isPrelude = moduleNameString moduleName == "Prelude"
93+ moduleName = unLoc ideclName
94+importId _ = notImplemented "XImportDecl"
4695
47−-- | Sort located import or export.
48−sortLies :: [LIE GhcPs] -> [LIE GhcPs]
49−sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
96+-- | Normalize a collection of import\/export items.
97+normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]
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
50151
51−-- | Sort imports\/exports inside of 'IEThingWith'.
52−sortThings :: IE GhcPs -> IE GhcPs
53−sortThings = \case
54− IEThingWith NoExtField x w xs fl ->
55− IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl
56− other -> other
152+-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an
153+-- 'Ord' instance for it.
154+newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName)
155+ deriving (Eq)
57156
58−-- | Compare two located imports or exports.
59−compareIE :: IE GhcPs -> IE GhcPs -> Ordering
60−compareIE = compareIewn `on` getIewn
157+instance Ord IEWrappedNameOrd where
158+ compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y
61159
62160-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
63−getIewn :: IE GhcPs -> IEWrappedName RdrName
161+getIewn :: IE GhcPs -> IEWrappedNameOrd
64162getIewn = \case
65− IEVar NoExtField x -> unLoc x
66− IEThingAbs NoExtField x -> unLoc x
67− IEThingAll NoExtField x -> unLoc x
68− IEThingWith NoExtField x _ _ _ -> unLoc x
163+ IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)
164+ IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)
165+ IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)
166+ IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)
69167 IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
70168 IEGroup NoExtField _ _ -> notImplemented "IEGroup"
71169 IEDoc NoExtField _ -> notImplemented "IEDoc"
72170 IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
73171 XIE x -> noExtCon x
74172
173+-- | Like 'compareIewn' for located wrapped names.
174+compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering
175+compareLIewn = compareIewn `on` unLoc
176+
75177-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
76178compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
77−compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y
179+compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y
78180compareIewn (IEName _) (IEPattern _) = LT
79181compareIewn (IEName _) (IEType _) = LT
80182compareIewn (IEPattern _) (IEName _) = GT
81−compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y
183+compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y
82184compareIewn (IEPattern _) (IEType _) = LT
83185compareIewn (IEType _) (IEName _) = GT
84186compareIewn (IEType _) (IEPattern _) = GT
85−compareIewn (IEType x) (IEType y) = unLoc x `compare` unLoc y
187+compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y
188+
189+compareRdrName :: RdrName -> RdrName -> Ordering
190+compareRdrName x y =
191+ case (getNameStr x, getNameStr y) of
192+ ([], []) -> EQ
193+ ((_ : _), []) -> GT
194+ ([], (_ : _)) -> LT
195+ ((x' : _), (y' : _)) ->
196+ case (isAlphaNum x', isAlphaNum y') of
197+ (False, False) -> x `compare` y
198+ (True, False) -> LT
199+ (False, True) -> GT
200+ (True, True) -> x `compare` y
201+ where
202+ getNameStr = showOutputable . rdrNameOcc
src/Ormolu/Parser.hs+52−100
@@ -12,12 +12,11 @@ where
1212import Bag (bagToList)
1313import qualified CmdLineParser as GHC
1414import Control.Exception
15−import Control.Monad
1615import Control.Monad.IO.Class
17−import Data.List ((\\), foldl', isPrefixOf, sortOn)
16+import qualified Data.List as L
1817import qualified Data.List.NonEmpty as NE
19−import Data.Maybe (catMaybes)
2018import Data.Ord (Down (Down))
19+import qualified Data.Text as T
2120import DynFlags as GHC
2221import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
2322import qualified FastString as GHC
@@ -32,6 +31,8 @@ import Ormolu.Exception
3231import Ormolu.Parser.Anns
3332import Ormolu.Parser.CommentStream
3433import Ormolu.Parser.Result
34+import Ormolu.Processing.Preprocess (preprocess)
35+import Ormolu.Utils (incSpanLine, removeIndentation)
3536import qualified Panic as GHC
3637import qualified Parser as GHC
3738import qualified StringBuffer as GHC
@@ -40,7 +41,7 @@ import qualified StringBuffer as GHC
4041parseModule ::
4142 MonadIO m =>
4243 -- | Ormolu configuration
43− Config ->
44+ Config RegionDeltas ->
4445 -- | File name (only for source location annotations)
4546 FilePath ->
4647 -- | Input for parser
@@ -49,8 +50,10 @@ parseModule ::
4950 ( [GHC.Warn],
5051 Either (SrcSpan, String) ParseResult
5152 )
52−parseModule Config {..} path input' = liftIO $ do
53− let (input, extraComments) = extractCommentsFromLines path input'
53+parseModule Config {..} path rawInput = liftIO $ do
54+ let (literalPrefix, indentedInput, literalSuffix, extraComments) =
55+ preprocess path rawInput cfgRegion
56+ (input, indent) = removeIndentation indentedInput
5457 -- It's important that 'setDefaultExts' is done before
5558 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
5659 -- extension that was explicitly disabled in the file.
@@ -60,7 +63,7 @@ parseModule Config {..} path input' = liftIO $ do
6063 (setDefaultExts baseDynFlags)
6164 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
6265 (warnings, dynFlags) <-
63− parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case
66+ parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case
6467 Right res -> pure res
6568 Left err ->
6669 let loc =
@@ -68,8 +71,6 @@ parseModule Config {..} path input' = liftIO $ do
6871 (mkSrcLoc (GHC.mkFastString path) 1 1)
6972 (mkSrcLoc (GHC.mkFastString path) 1 1)
7073 in throwIO (OrmoluParsingFailed loc err)
71− when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
72− throwIO (OrmoluCppEnabled path)
7374 let useRecordDot =
7475 "record-dot-preprocessor" == pgm_F dynFlags
7576 || any
@@ -77,15 +78,18 @@ parseModule Config {..} path input' = liftIO $ do
7778 (pluginModNames dynFlags)
7879 pStateErrors = \pstate ->
7980 let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
80− in case sortOn (Down . SeverityOrd . errMsgSeverity) errs of
81+ fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)
82+ in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of
8183 [] -> Nothing
82− err : _ -> Just (errMsgSpan err, show err) -- Show instance returns a short error message
84+ err : _ ->
85+ -- Show instance returns a short error message
86+ Just (fixupErrSpan (errMsgSpan err), show err)
8387 r = case runParser GHC.parseModule dynFlags path input of
8488 GHC.PFailed pstate ->
8589 case pStateErrors pstate of
8690 Just err -> Left err
87− Nothing -> error "invariant violation: PFailed does not have an error"
88− GHC.POk pstate pmod ->
91+ Nothing -> error "PFailed does not have an error"
92+ GHC.POk pstate (L _ hsModule) ->
8993 case pStateErrors pstate of
9094 -- Some parse errors (pattern/arrow syntax in expr context)
9195 -- do not cause a parse error, but they are replaced with "_"
@@ -93,20 +97,33 @@ parseModule Config {..} path input' = liftIO $ do
9397 -- later stages; but we fail in those cases.
9498 Just err -> Left err
9599 Nothing ->
96− let (comments, exts, shebangs) = mkCommentStream extraComments pstate
100+ let (stackHeader, shebangs, pragmas, comments) =
101+ mkCommentStream input extraComments pstate
97102 in Right
98103 ParseResult
99− { prParsedSource = pmod,
104+ { prParsedSource = hsModule,
100105 prAnns = mkAnns pstate,
101− prCommentStream = comments,
102− prExtensions = exts,
106+ prStackHeader = stackHeader,
103107 prShebangs = shebangs,
108+ prPragmas = pragmas,
109+ prCommentStream = comments,
104110 prUseRecordDot = useRecordDot,
105111 prImportQualifiedPost =
106− GHC.xopt ImportQualifiedPost dynFlags
112+ GHC.xopt ImportQualifiedPost dynFlags,
113+ prLiteralPrefix = T.pack literalPrefix,
114+ prLiteralSuffix = T.pack literalSuffix,
115+ prIndent = indent
107116 }
108117 return (warnings, r)
109118
119+-- | Enable all language extensions that we think should be enabled by
120+-- default for ease of use.
121+setDefaultExts :: DynFlags -> DynFlags
122+setDefaultExts flags = L.foldl' xopt_set flags autoExts
123+ where
124+ autoExts = allExts L.\\ manualExts
125+ allExts = [minBound .. maxBound]
126+
110127-- | Extensions that are not enabled automatically and should be activated
111128-- by user.
112129manualExts :: [Extension]
@@ -133,9 +150,6 @@ manualExts =
133150 -- decision of enabling this style is left to the user
134151 ]
135152
136−----------------------------------------------------------------------------
137−-- Helpers (taken from ghc-exactprint)
138−
139153-- | Run a 'GHC.P' computation.
140154runParser ::
141155 -- | Computation to run
@@ -154,67 +168,27 @@ runParser parser flags filename input = GHC.unP parser parseState
154168 buffer = GHC.stringToStringBuffer input
155169 parseState = GHC.mkPState flags buffer location
156170
157−-- | Transform given lines possibly returning comments extracted from them.
158−-- This handles LINE pragmas and shebangs.
159−extractCommentsFromLines ::
160− -- | File name, just to use in the spans
161− FilePath ->
162− -- | List of lines from that file
163− String ->
164− -- | Adjusted lines together with comments extracted from them
165− (String, [Located String])
166−extractCommentsFromLines path =
167− unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines
168− where
169− unlines' (a, b) = (unlines a, catMaybes b)
170−
171−-- | Transform a given line possibly returning a comment extracted from it.
172−extractCommentFromLine ::
173− -- | File name, just to use in the spans
174− FilePath ->
175− -- | Line number of this line
176− Int ->
177− -- | The actual line
178− String ->
179− -- | Adjusted line and possibly a comment extracted from it
180− (String, Maybe (Located String))
181−extractCommentFromLine path line s
182− | "{-# LINE" `isPrefixOf` s =
183− let (pragma, res) = getPragma s
184− size = length pragma
185− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
186− in (res, Just $ L ss pragma)
187− | isShebang s =
188− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
189− in ("", Just $ L ss s)
190− | otherwise = (s, Nothing)
191− where
192− mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
171+-- | Wrap GHC's 'Severity' to add 'Ord' instance.
172+newtype SeverityOrd = SeverityOrd Severity
193173
194−-- | Take a line pragma and output its replacement (where line pragma is
195−-- replaced with spaces) and the contents of the pragma itself.
196−getPragma ::
197− -- | Pragma line to analyze
198− String ->
199− -- | Contents of the pragma and its replacement line
200− (String, String)
201−getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
202−getPragma s@(x : xs)
203− | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
204− | otherwise =
205− let (prag, remline) = getPragma xs
206− in (x : prag, ' ' : remline)
174+instance Eq SeverityOrd where
175+ s1 == s2 = compare s1 s2 == EQ
207176
208−-- | Enable all language extensions that we think should be enabled by
209−-- default for ease of use.
210−setDefaultExts :: DynFlags -> DynFlags
211−setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
212− where
213− autoExts = allExts \\ manualExts
214− allExts = [minBound .. maxBound]
177+instance Ord SeverityOrd where
178+ compare (SeverityOrd s1) (SeverityOrd s2) =
179+ compare (f s1) (f s2)
180+ where
181+ f :: Severity -> Int
182+ f SevOutput = 1
183+ f SevFatal = 2
184+ f SevInteractive = 3
185+ f SevDump = 4
186+ f SevInfo = 5
187+ f SevWarning = 6
188+ f SevError = 7
215189
216190----------------------------------------------------------------------------
217−-- More helpers (taken from HLint)
191+-- Helpers taken from HLint
218192
219193parsePragmasIntoDynFlags ::
220194 -- | Pre-set 'DynFlags'
@@ -243,25 +217,3 @@ parsePragmasIntoDynFlags flags extraOpts filepath str =
243217 reportErr
244218 (GHC.handleSourceError reportErr act)
245219 reportErr e = return $ Left (show e)
246−
247−----------------------------------------------------------------------------
248−-- Even more helpers
249−
250−-- Wrap GHC's ErrUtils.Severity to add Ord instance
251−newtype SeverityOrd = SeverityOrd Severity
252−
253−instance Eq SeverityOrd where
254− s1 == s2 = compare s1 s2 == EQ
255−
256−instance Ord SeverityOrd where
257− compare (SeverityOrd s1) (SeverityOrd s2) =
258− compare (f s1) (f s2)
259− where
260− f :: Severity -> Int
261− f SevOutput = 1
262− f SevFatal = 2
263− f SevInteractive = 3
264− f SevDump = 4
265− f SevInfo = 5
266− f SevWarning = 6
267− f SevError = 7
src/Ormolu/Parser/CommentStream.hs+147−61
@@ -4,78 +4,74 @@
44
55-- | Functions for working with comment stream.
66module Ormolu.Parser.CommentStream
7− ( CommentStream (..),
8− Comment (..),
7+ ( -- * Comment stream
8+ CommentStream (..),
99 mkCommentStream,
10− isShebang,
11− isPrevHaddock,
12− isMultilineComment,
1310 showCommentStream,
11+
12+ -- * Comment
13+ Comment (..),
14+ unComment,
15+ hasAtomsBefore,
16+ isMultilineComment,
1417 )
1518where
1619
1720import Data.Char (isSpace)
1821import Data.Data (Data)
19−import Data.Either (partitionEithers)
20−import Data.List (dropWhileEnd, isPrefixOf, sortOn)
22+import qualified Data.List as L
2123import Data.List.NonEmpty (NonEmpty (..))
2224import qualified Data.List.NonEmpty as NE
2325import Data.Maybe (mapMaybe)
2426import qualified GHC
2527import qualified Lexer as GHC
2628import Ormolu.Parser.Pragma
27−import Ormolu.Utils (showOutputable)
29+import Ormolu.Parser.Shebang
30+import Ormolu.Processing.Common
31+import Ormolu.Utils (onTheSameLine, showOutputable)
2832import SrcLoc
2933
34+----------------------------------------------------------------------------
35+-- Comment stream
36+
3037-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
3138-- beginning of corresponding spans.
3239newtype CommentStream = CommentStream [RealLocated Comment]
3340 deriving (Eq, Data, Semigroup, Monoid)
3441
35−-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
36−-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
37−newtype Comment = Comment (NonEmpty String)
38− deriving (Eq, Show, Data)
39−
4042-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are
4143-- removed from the 'CommentStream'. Shebangs are only extracted from the
4244-- comments that come from the first argument.
4345mkCommentStream ::
46+ -- | Original input
47+ String ->
4448 -- | Extra comments to include
4549 [Located String] ->
4650 -- | Parser state to use for comment extraction
4751 GHC.PState ->
48− -- | Comment stream, a set of extracted pragmas, and extracted shebangs
49− (CommentStream, [Pragma], [Located String])
50−mkCommentStream extraComments pstate =
51− ( CommentStream $
52− mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,
52+ -- | Stack header, shebangs, pragmas, and comment stream
53+ ( Maybe (RealLocated Comment),
54+ [Shebang],
55+ [([RealLocated Comment], Pragma)],
56+ CommentStream
57+ )
58+mkCommentStream input extraComments pstate =
59+ ( mstackHeader,
60+ shebangs,
5361 pragmas,
54− shebangs
62+ CommentStream comments
5563 )
5664 where
57− (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
58− rawComments =
59− mapMaybe toRealSpan $
65+ (comments, pragmas) = extractPragmas input rawComments1
66+ (rawComments1, mstackHeader) = extractStackHeader rawComments0
67+ rawComments0 =
68+ L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $
6069 otherExtraComments
6170 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
6271 ++ concatMap
6372 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
6473 (GHC.annotations_comments pstate)
65− (shebangs, otherExtraComments) = span (isShebang . unLoc) extraComments
66−
67−-- | Return 'True' if given 'String' is a shebang.
68−isShebang :: String -> Bool
69−isShebang str = "#!" `isPrefixOf` str
70−
71−-- | Test whether a 'Comment' looks like a Haddock following a definition,
72−-- i.e. something starting with @-- ^@.
73−isPrevHaddock :: Comment -> Bool
74−isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
75−
76−-- | Is this comment multiline-style?
77−isMultilineComment :: Comment -> Bool
78−isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
74+ (shebangs, otherExtraComments) = extractShebangs extraComments
7975
8076-- | Pretty-print a 'CommentStream'.
8177showCommentStream :: CommentStream -> String
@@ -86,28 +82,117 @@ showCommentStream (CommentStream xs) =
8682 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
8783
8884----------------------------------------------------------------------------
89−-- Helpers
85+-- Comment
86+
87+-- | A wrapper for a single comment. The 'Bool' indicates whether there were
88+-- atoms before beginning of the comment in the original input. The
89+-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or
90+-- just single item\/line otherwise.
91+data Comment = Comment Bool (NonEmpty String)
92+ deriving (Eq, Show, Data)
9093
9194-- | Normalize comment string. Sometimes one multi-line comment is turned
9295-- into several lines for subsequent outputting with correct indentation for
9396-- each line.
94−mkComment :: RealLocated String -> RealLocated Comment
95−mkComment (L l s) =
96− L l . Comment . fmap dropTrailing $
97− if "{-" `isPrefixOf` s
98− then case NE.nonEmpty (lines s) of
99− Nothing -> s :| []
100− Just (x :| xs) ->
101− let getIndent y =
102− if all isSpace y
103− then startIndent
104− else length (takeWhile isSpace y)
105− n = minimum (startIndent : fmap getIndent xs)
106− in x :| (drop n <$> xs)
107− else s :| []
97+mkComment ::
98+ -- | Lines of original input with their indices
99+ [(Int, String)] ->
100+ -- | Raw comment string
101+ RealLocated String ->
102+ -- | Remaining lines of original input and the constructed 'Comment'
103+ ([(Int, String)], RealLocated Comment)
104+mkComment ls (L l s) = (ls', comment)
108105 where
109− dropTrailing = dropWhileEnd isSpace
106+ comment =
107+ L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $
108+ if "{-" `L.isPrefixOf` s
109+ then case NE.nonEmpty (lines s) of
110+ Nothing -> s :| []
111+ Just (x :| xs) ->
112+ let getIndent y =
113+ if all isSpace y || y == endDisabling
114+ then startIndent
115+ else length (takeWhile isSpace y)
116+ n = minimum (startIndent : fmap getIndent xs)
117+ removeIndent y =
118+ if y == endDisabling
119+ then y
120+ else drop n y
121+ in x :| (removeIndent <$> xs)
122+ else s :| []
123+ (atomsBefore, ls') =
124+ case dropWhile ((< commentLine) . fst) ls of
125+ [] -> (False, [])
126+ ((_, i) : ls'') ->
127+ case take 2 (dropWhile isSpace i) of
128+ "--" -> (False, ls'')
129+ "{-" -> (False, ls'')
130+ _ -> (True, ls'')
131+ dropTrailing = L.dropWhileEnd isSpace
110132 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
111196
112197-- | Get a 'String' from 'GHC.AnnotationComment'.
113198unAnnotationComment :: GHC.AnnotationComment -> Maybe String
@@ -129,12 +214,13 @@ toRealSpan :: Located a -> Maybe (RealLocated a)
129214toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
130215toRealSpan _ = Nothing
131216
132−-- | If a given comment is a pragma, return it in parsed form in 'Right'.
133−-- Otherwise return the original comment unchanged.
134−partitionComments ::
135− RealLocated String ->
136− Either (RealLocated String) Pragma
137−partitionComments input =
138− case parsePragma (unRealSrcSpan input) of
139− Nothing -> Left input
140− Just pragma -> Right pragma
217+-- | Remove consecutive blank lines.
218+removeConseqBlanks :: NonEmpty String -> NonEmpty String
219+removeConseqBlanks (x :| xs) = x :| go (null x) id xs
220+ where
221+ go seenBlank acc = \case
222+ [] -> acc []
223+ (y : ys) ->
224+ if seenBlank && null y
225+ then go True acc ys
226+ else go (null y) (acc . (y :)) ys
src/Ormolu/Parser/Pragma.hs+4−4
@@ -10,7 +10,7 @@ where
1010
1111import Control.Monad
1212import Data.Char (isSpace, toLower)
13−import Data.List
13+import qualified Data.List as L
1414import qualified EnumSet as ES
1515import FastString (mkFastString, unpackFS)
1616import qualified Lexer as L
@@ -35,8 +35,8 @@ parsePragma ::
3535 String ->
3636 Maybe Pragma
3737parsePragma input = do
38− inputNoPrefix <- stripPrefix "{-#" input
39− guard ("#-}" `isSuffixOf` input)
38+ inputNoPrefix <- L.stripPrefix "{-#" input
39+ guard ("#-}" `L.isSuffixOf` input)
4040 let contents = take (length inputNoPrefix - 3) inputNoPrefix
4141 (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents
4242 case toLower <$> pragmaName of
@@ -46,7 +46,7 @@ parsePragma input = do
4646 _ -> Nothing
4747 where
4848 trimSpaces :: String -> String
49− trimSpaces = dropWhileEnd isSpace . dropWhile isSpace
49+ trimSpaces = L.dropWhileEnd isSpace . dropWhile isSpace
5050
5151-- | Assuming the input consists of a series of tokens from a language
5252-- pragma, return the set of enabled extensions.
src/Ormolu/Parser/Result.hs+26−17
@@ -7,29 +7,38 @@ module Ormolu.Parser.Result
77 )
88where
99
10+import Data.Text (Text)
1011import GHC
1112import Ormolu.Parser.Anns
1213import Ormolu.Parser.CommentStream
1314import Ormolu.Parser.Pragma (Pragma)
15+import Ormolu.Parser.Shebang (Shebang)
1416
1517-- | A collection of data that represents a parsed module in Ormolu.
16−data ParseResult
17− = ParseResult
18− { -- | 'ParsedSource' from GHC
19− prParsedSource :: ParsedSource,
20− -- | Ormolu-specfic representation of annotations
21− prAnns :: Anns,
22− -- | Comment stream
23− prCommentStream :: CommentStream,
24− -- | Extensions enabled in that module
25− prExtensions :: [Pragma],
26− -- | Shebangs found in the input
27− prShebangs :: [Located String],
28− -- | Whether or not record dot syntax is enabled
29− prUseRecordDot :: Bool,
30− -- | Whether or not ImportQualifiedPost is enabled
31− prImportQualifiedPost :: Bool
32− }
18+data ParseResult = ParseResult
19+ { -- | 'ParsedSource' from GHC
20+ prParsedSource :: HsModule GhcPs,
21+ -- | Ormolu-specfic representation of annotations
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)],
29+ -- | Comment stream
30+ prCommentStream :: CommentStream,
31+ -- | Whether or not record dot syntax is enabled
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
41+ }
3342
3443-- | Pretty-print a 'ParseResult'.
3544prettyPrintParseResult :: ParseResult -> String
src/Ormolu/Parser/Shebang.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+-- | A module for dealing with shebangs.
4+module Ormolu.Parser.Shebang
5+ ( Shebang (..),
6+ extractShebangs,
7+ isShebang,
8+ )
9+where
10+
11+import Data.Data (Data)
12+import qualified Data.List as L
13+import SrcLoc
14+
15+-- | A wrapper for a shebang.
16+newtype Shebang = Shebang (Located String)
17+ deriving (Eq, Data)
18+
19+-- | Extract shebangs from the beginning of a comment stream.
20+extractShebangs :: [Located String] -> ([Shebang], [Located String])
21+extractShebangs comments = (Shebang <$> shebangs, rest)
22+ where
23+ (shebangs, rest) = span (isShebang . unLoc) comments
24+
25+-- | Return 'True' if given 'String' is a shebang.
26+isShebang :: String -> Bool
27+isShebang str = "#!" `L.isPrefixOf` str
src/Ormolu/Printer.hs+17−11
@@ -11,6 +11,7 @@ import Ormolu.Parser.Result
1111import Ormolu.Printer.Combinators
1212import Ormolu.Printer.Meat.Module
1313import Ormolu.Printer.SpanStream
14+import Ormolu.Processing.Postprocess (postprocess)
1415
1516-- | Render a module.
1617printModule ::
@@ -19,14 +20,19 @@ printModule ::
1920 -- | Resulting rendition
2021 Text
2122printModule ParseResult {..} =
22− runR
23− ( p_hsModule
24− prShebangs
25− prExtensions
26− prImportQualifiedPost
27− prParsedSource
28− )
29− (mkSpanStream prParsedSource)
30− prCommentStream
31− prAnns
32− prUseRecordDot
23+ prLiteralPrefix <> region <> prLiteralSuffix
24+ where
25+ region =
26+ postprocess prIndent $
27+ runR
28+ ( p_hsModule
29+ prStackHeader
30+ prShebangs
31+ prPragmas
32+ prImportQualifiedPost
33+ prParsedSource
34+ )
35+ (mkSpanStream prParsedSource)
36+ prCommentStream
37+ prAnns
38+ prUseRecordDot
src/Ormolu/Printer/Combinators.hs+39−29
@@ -21,6 +21,7 @@ module Ormolu.Printer.Combinators
2121 space,
2222 newline,
2323 inci,
24+ inciIf,
2425 located,
2526 located',
2627 switchLayout,
@@ -51,57 +52,57 @@ module Ormolu.Printer.Combinators
5152
5253 -- ** Literals
5354 comma,
55+ commaDel,
56+ equals,
5457
55− -- ** Comments
58+ -- ** Stateful markers
59+ SpanMark (..),
60+ spanMarkSpan,
5661 HaddockStyle (..),
57− setLastCommentSpan,
58− getLastCommentSpan,
62+ setSpanMark,
63+ getSpanMark,
5964 )
6065where
6166
6267import Control.Monad
63−import Data.Data (Data)
6468import Data.List (intersperse)
6569import Data.Text (Text)
6670import Ormolu.Printer.Comments
6771import Ormolu.Printer.Internal
68−import Ormolu.Utils (isModule)
6972import SrcLoc
7073
7174----------------------------------------------------------------------------
7275-- Basic
7376
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+
7486-- | Enter a 'Located' entity. This combinator handles outputting comments
7587-- and sets layout (single-line vs multi-line) for the inner computation.
7688-- Roughly, the rule for using 'located' is that every time there is a
7789-- 'Located' wrapper, it should be “discharged” with a corresponding
7890-- 'located' invocation.
7991located ::
80− Data a =>
8192 -- | Thing to enter
8293 Located a ->
8394 -- | How to render inner value
8495 (a -> R ()) ->
8596 R ()
86−located loc f = do
87− let withRealLocated (L l a) g =
88− case l of
89− UnhelpfulSpan _ -> return ()
90− RealSrcSpan l' -> g (L l' a)
91− withRealLocated loc spitPrecedingComments
92− let setEnclosingSpan =
93− case getLoc loc of
94− UnhelpfulSpan _ -> id
95− RealSrcSpan orf ->
96− if isModule (unLoc loc)
97− then id
98− else withEnclosingSpan orf
99− setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))
100− withRealLocated loc spitFollowingComments
97+located (L (UnhelpfulSpan _) a) f = f a
98+located (L (RealSrcSpan l) a) f = do
99+ spitPrecedingComments l
100+ withEnclosingSpan l $
101+ switchLayout [RealSrcSpan l] (f a)
102+ spitFollowingComments l
101103
102104-- | A version of 'located' with arguments flipped.
103105located' ::
104− Data a =>
105106 -- | How to render inner value
106107 (a -> R ()) ->
107108 -- | Thing to enter
@@ -184,10 +185,12 @@ sepSemi f xs = vlayout singleLine multiLine
184185 xs' ->
185186 if ub
186187 then do
187− txt "{ "
188− sep (txt "; ") (dontUseBraces . f) xs'
189− txt " }"
190− else sep (txt "; ") f xs'
188+ txt "{"
189+ space
190+ sep (txt ";" >> space) (dontUseBraces . f) xs'
191+ space
192+ txt "}"
193+ else sep (txt ";" >> space) f xs'
191194 multiLine =
192195 sep newline (dontUseBraces . f) xs
193196
@@ -200,6 +203,7 @@ data BracketStyle
200203 N
201204 | -- | Shifted one level
202205 S
206+ deriving (Eq, Show)
203207
204208-- | Surround given entity by backticks.
205209backticks :: R () -> R ()
@@ -276,9 +280,7 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
276280 then newline >> inci m
277281 else space >> sitcc m
278282 newline
279− case style of
280− N -> txt close
281− S -> inci (txt close)
283+ inciIf (style == S) (txt close)
282284
283285----------------------------------------------------------------------------
284286-- Literals
@@ -286,3 +288,11 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
286288-- | Print @,@.
287289comma :: R ()
288290comma = txt ","
291+
292+-- | Delimiting combination with 'comma'. To be used with 'sep'.
293+commaDel :: R ()
294+commaDel = comma >> breakpoint
295+
296+-- | Print @=@. Do not use @'txt' "="@.
297+equals :: R ()
298+equals = interferingTxt "="
src/Ormolu/Printer/Comments.hs+62−76
@@ -1,3 +1,4 @@
1+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
23
34-- | Helpers for formatting of comments. This is low-level code, use
@@ -6,21 +7,17 @@ module Ormolu.Printer.Comments
67 ( spitPrecedingComments,
78 spitFollowingComments,
89 spitRemainingComments,
9− spitStackHeader,
10+ spitCommentNow,
11+ spitCommentPending,
1012 )
1113where
1214
1315import Control.Monad
14−import Data.Char (isSpace)
15−import Data.Coerce (coerce)
16−import Data.Data (Data)
17−import Data.List (isPrefixOf)
1816import qualified Data.List.NonEmpty as NE
19−import Data.List.NonEmpty (NonEmpty (..))
17+import Data.Maybe (listToMaybe)
2018import qualified Data.Text as T
2119import Ormolu.Parser.CommentStream
2220import Ormolu.Printer.Internal
23−import Ormolu.Utils (isModule)
2421import SrcLoc
2522
2623----------------------------------------------------------------------------
@@ -28,108 +25,91 @@ import SrcLoc
2825
2926-- | Output all preceding comments for an element at given location.
3027spitPrecedingComments ::
31− Data a =>
32− -- | AST element to attach comments to
33− RealLocated a ->
28+ -- | Span of the element to attach comments to
29+ RealSrcSpan ->
3430 R ()
3531spitPrecedingComments ref = do
3632 gotSome <- handleCommentSeries (spitPrecedingComment ref)
3733 when gotSome $ do
34+ lastMark <- getSpanMark
3835 -- Insert a blank line between the preceding comments and the thing
3936 -- after them if there was a blank line in the input.
40− lastSpn <- fmap snd <$> getLastCommentSpan
41− when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline
37+ when (needsNewlineBefore ref lastMark) newline
4238
4339-- | Output all comments following an element at given location.
4440spitFollowingComments ::
45− Data a =>
46− -- | AST element of attach comments to
47− RealLocated a ->
41+ -- | Span of the element to attach comments to
42+ RealSrcSpan ->
4843 R ()
4944spitFollowingComments ref = do
50− trimSpanStream (getRealSrcSpan ref)
45+ trimSpanStream ref
5146 void $ handleCommentSeries (spitFollowingComment ref)
5247
5348-- | Output all remaining comments in the comment stream.
5449spitRemainingComments :: R ()
55−spitRemainingComments = void $ handleCommentSeries spitRemainingComment
56−
57−-- | If there is a stack header in the comment stream, print it.
58−spitStackHeader :: R ()
59−spitStackHeader = do
60− let isStackHeader (Comment (x :| _)) =
61− "stack" `isPrefixOf` dropWhile isSpace (drop 2 x)
62− mstackHeader <- popComment (isStackHeader . unRealSrcSpan)
63− forM_ mstackHeader $ \(L spn x) -> do
64− spitCommentNow spn x
65− newline
50+spitRemainingComments = do
51+ -- Make sure we have a blank a line between the last definition and the
52+ -- trailing comments.
53+ newline
54+ void $ handleCommentSeries spitRemainingComment
6655
6756----------------------------------------------------------------------------
6857-- Single-comment functions
6958
7059-- | Output a single preceding comment for an element at given location.
7160spitPrecedingComment ::
72− Data a =>
73− -- | AST element to attach comments to
74− RealLocated a ->
75− -- | Location of last comment in the series
76− Maybe RealSrcSpan ->
61+ -- | Span of the element to attach comments to
62+ RealSrcSpan ->
7763 -- | Are we done?
7864 R Bool
79−spitPrecedingComment (L ref a) mlastSpn = do
65+spitPrecedingComment ref = do
66+ mlastMark <- getSpanMark
8067 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
8168 withPoppedComment p $ \l comment -> do
82− dirtyLine <-
83− case mlastSpn of
84− -- When the current line is dirty it means that something that can
85− -- have comments attached to it is already on the line. To avoid
86− -- problems with idempotence we cannot output the first comment
87− -- immediately because it'll be attached to the previous element (on
88− -- the same line) on the next run, so we play safe here and output
89− -- an extra 'newline' in this case.
90− Nothing -> isLineDirty -- only for very first preceding comment
91− Just _ -> return False
92− when (dirtyLine || needsNewlineBefore l mlastSpn) newline
69+ lineSpans <- thisLineSpans
70+ let thisCommentLine = srcLocLine (realSrcSpanStart l)
71+ needsNewline =
72+ case listToMaybe lineSpans of
73+ Nothing -> False
74+ Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine
75+ when (needsNewline || needsNewlineBefore l mlastMark) newline
9376 spitCommentNow l comment
94− if theSameLinePre l ref && not (isModule a)
77+ if theSameLinePre l ref
9578 then space
9679 else newline
9780
9881-- | Output a comment that follows element at given location immediately on
9982-- the same line, if there is any.
10083spitFollowingComment ::
101− Data a =>
10284 -- | AST element to attach comments to
103− RealLocated a ->
104− -- | Location of last comment in the series
105− Maybe RealSrcSpan ->
85+ RealSrcSpan ->
10686 -- | Are we done?
10787 R Bool
108−spitFollowingComment (L ref a) mlastSpn = do
88+spitFollowingComment ref = do
89+ mlastMark <- getSpanMark
10990 mnSpn <- nextEltSpan
11091 -- Get first enclosing span that is not equal to reference span, i.e. it's
11192 -- truly something enclosing the AST element.
11293 meSpn <- getEnclosingSpan (/= ref)
113− withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
114− if theSameLinePost l ref && not (isModule a)
94+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->
95+ if theSameLinePost l ref
11596 then
11697 if isMultilineComment comment
11798 then space >> spitCommentNow l comment
11899 else spitCommentPending OnTheSameLine l comment
119100 else do
120− when (needsNewlineBefore l mlastSpn) $
101+ when (needsNewlineBefore l mlastMark) $
121102 registerPendingCommentLine OnNextLine ""
122103 spitCommentPending OnNextLine l comment
123104
124105-- | Output a single remaining comment from the comment stream.
125106spitRemainingComment ::
126− -- | Location of last comment in the series
127− Maybe RealSrcSpan ->
128107 -- | Are we done?
129108 R Bool
130−spitRemainingComment mlastSpn =
109+spitRemainingComment = do
110+ mlastMark <- getSpanMark
131111 withPoppedComment (const True) $ \l comment -> do
132− when (needsNewlineBefore l mlastSpn) newline
112+ when (needsNewlineBefore l mlastMark) newline
133113 spitCommentNow l comment
134114 newline
135115
@@ -140,13 +120,13 @@ spitRemainingComment mlastSpn =
140120handleCommentSeries ::
141121 -- | Given location of previous comment, output the next comment
142122 -- returning 'True' if we're done
143− (Maybe RealSrcSpan -> R Bool) ->
123+ R Bool ->
144124 -- | Whether we printed any comments
145125 R Bool
146126handleCommentSeries f = go False
147127 where
148128 go gotSome = do
149− done <- getLastCommentSpan >>= f . fmap snd
129+ done <- f
150130 if done
151131 then return gotSome
152132 else go True
@@ -172,13 +152,14 @@ needsNewlineBefore ::
172152 -- | Current comment span
173153 RealSrcSpan ->
174154 -- | Last printed comment span
175− Maybe RealSrcSpan ->
155+ Maybe SpanMark ->
176156 Bool
177−needsNewlineBefore l mlastSpn =
178− case mlastSpn of
157+needsNewlineBefore _ (Just (HaddockSpan _ _)) = True
158+needsNewlineBefore l mlastMark =
159+ case spanMarkSpan <$> mlastMark of
179160 Nothing -> False
180− Just lastSpn ->
181− srcSpanStartLine l > srcSpanEndLine lastSpn + 1
161+ Just lastMark ->
162+ srcSpanStartLine l > srcSpanEndLine lastMark + 1
182163
183164-- | Is the preceding comment and AST element are on the same line?
184165theSameLinePre ::
@@ -209,11 +190,11 @@ commentFollowsElt ::
209190 -- | Location of enclosing AST element
210191 Maybe RealSrcSpan ->
211192 -- | Location of last comment in the series
212− Maybe RealSrcSpan ->
193+ Maybe SpanMark ->
213194 -- | Comment to test
214195 RealLocated Comment ->
215196 Bool
216−commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
197+commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =
217198 -- A comment follows a AST element if all 4 conditions are satisfied:
218199 goesAfter
219200 && logicallyFollows
@@ -226,9 +207,8 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
226207 -- 2) The comment logically belongs to the element, four cases:
227208 logicallyFollows =
228209 theSameLinePost l ref -- a) it's on the same line
229− || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
230− || continuation -- c) it's a continuation of a comment block
231− || lastInEnclosing -- d) it's the last element in the enclosing construct
210+ || continuation -- b) it's a continuation of a comment block
211+ || lastInEnclosing -- c) it's the last element in the enclosing construct
232212
233213 -- 3) There is no other AST element between this element and the comment:
234214 noEltBetween =
@@ -255,9 +235,15 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
255235 >= abs (startColumn ref - startColumn l)
256236 )
257237 continuation =
258− case mlastSpn of
259− Nothing -> False
260− Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
238+ -- A comment is a continuation when it doesn't have non-whitespace
239+ -- lexemes in front of it and goes right after the previous comment.
240+ not (hasAtomsBefore comment)
241+ && ( case mlastMark of
242+ Just (HaddockSpan _ _) -> False
243+ Just (CommentSpan spn) ->
244+ srcSpanEndLine spn + 1 == srcSpanStartLine l
245+ _ -> False
246+ )
261247 lastInEnclosing =
262248 case meSpn of
263249 -- When there is no enclosing element, return false
@@ -279,9 +265,9 @@ spitCommentNow spn comment = do
279265 . sequence_
280266 . NE.intersperse newline
281267 . fmap (txt . T.pack)
282− . coerce
268+ . unComment
283269 $ comment
284− setLastCommentSpan Nothing spn
270+ setSpanMark (CommentSpan spn)
285271
286272-- | Output a 'Comment' at the end of correct line or after it depending on
287273-- 'CommentPosition'. Used for comments that may potentially follow on the
@@ -295,6 +281,6 @@ spitCommentPending position spn comment = do
295281 . sequence_
296282 . NE.toList
297283 . fmap (registerPendingCommentLine position . T.pack)
298− . coerce
284+ . unComment
299285 $ comment
300− setLastCommentSpan Nothing spn
286+ setSpanMark (CommentSpan spn)
src/Ormolu/Printer/Internal.hs+149−96
@@ -1,4 +1,5 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RankNTypes #-}
45
@@ -13,10 +14,10 @@ module Ormolu.Printer.Internal
1314
1415 -- * Internal functions
1516 txt,
17+ interferingTxt,
1618 atom,
1719 space,
1820 newline,
19− isLineDirty,
2021 useRecordDot,
2122 inci,
2223 sitcc,
@@ -38,9 +39,14 @@ module Ormolu.Printer.Internal
3839 popComment,
3940 getEnclosingSpan,
4041 withEnclosingSpan,
42+ thisLineSpans,
43+
44+ -- * Stateful markers
45+ SpanMark (..),
46+ spanMarkSpan,
4147 HaddockStyle (..),
42− setLastCommentSpan,
43− getLastCommentSpan,
48+ setSpanMark,
49+ getSpanMark,
4450
4551 -- * Annotations
4652 getAnns,
@@ -73,45 +79,44 @@ newtype R a = R (ReaderT RC (State SC) a)
7379
7480-- | Reader context of 'R'. This should be used when we control rendering by
7581-- enclosing certain expressions with wrappers.
76−data RC
77− = RC
78− { -- | Indentation level, as the column index we need to start from after
79− -- a newline if we break lines
80− rcIndent :: !Int,
81− -- | Current layout
82− rcLayout :: Layout,
83− -- | Spans of enclosing elements of AST
84− rcEnclosingSpans :: [RealSrcSpan],
85− -- | Collection of annotations
86− rcAnns :: Anns,
87− -- | Whether the last expression in the layout can use braces
88− rcCanUseBraces :: Bool,
89− -- | Whether the source could have used the record dot preprocessor
90− rcUseRecDot :: Bool
91− }
82+data RC = RC
83+ { -- | Indentation level, as the column index we need to start from after
84+ -- a newline if we break lines
85+ rcIndent :: !Int,
86+ -- | Current layout
87+ rcLayout :: Layout,
88+ -- | Spans of enclosing elements of AST
89+ rcEnclosingSpans :: [RealSrcSpan],
90+ -- | Collection of annotations
91+ rcAnns :: Anns,
92+ -- | Whether the last expression in the layout can use braces
93+ rcCanUseBraces :: Bool,
94+ -- | Whether the source could have used the record dot preprocessor
95+ rcUseRecDot :: Bool
96+ }
9297
9398-- | State context of 'R'.
94−data SC
95− = SC
96− { -- | Index of the next column to render
97− scColumn :: !Int,
98− -- | Rendered source code so far
99− scBuilder :: Builder,
100− -- | Span stream
101− scSpanStream :: SpanStream,
102− -- | Comment stream
103− scCommentStream :: CommentStream,
104− -- | Pending comment lines (in reverse order) to be inserted before next
105− -- newline, 'Int' is the indentation level
106− scPendingComments :: ![(CommentPosition, Int, Text)],
107− -- | Whether the current line is “dirty”, that is, already contains
108− -- atoms that can have comments attached to them
109− scDirtyLine :: !Bool,
110− -- | Whether to output a space before the next output
111− scRequestedDelimiter :: !RequestedDelimiter,
112− -- | Span of last output comment
113− scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
114− }
99+data SC = SC
100+ { -- | Index of the next column to render
101+ scColumn :: !Int,
102+ -- | Indentation level that was used for the current line
103+ scIndent :: !Int,
104+ -- | Rendered source code so far
105+ scBuilder :: Builder,
106+ -- | Span stream
107+ scSpanStream :: SpanStream,
108+ -- | Spans of atoms that have been printed on the current line so far
109+ scThisLineSpans :: [RealSrcSpan],
110+ -- | Comment stream
111+ scCommentStream :: CommentStream,
112+ -- | Pending comment lines (in reverse order) to be inserted before next
113+ -- newline, 'Int' is the indentation level
114+ scPendingComments :: ![(CommentPosition, Text)],
115+ -- | Whether to output a space before the next output
116+ scRequestedDelimiter :: !RequestedDelimiter,
117+ -- | An auxiliary marker for keeping track of last output element
118+ scSpanMark :: !(Maybe SpanMark)
119+ }
115120
116121-- | Make sure next output is delimited by one of the following.
117122data RequestedDelimiter
@@ -172,18 +177,36 @@ runR (R m) sstream cstream anns recDot =
172177 sc =
173178 SC
174179 { scColumn = 0,
180+ scIndent = 0,
175181 scBuilder = mempty,
176182 scSpanStream = sstream,
183+ scThisLineSpans = [],
177184 scCommentStream = cstream,
178185 scPendingComments = [],
179− scDirtyLine = False,
180186 scRequestedDelimiter = VeryBeginning,
181− scLastCommentSpan = Nothing
187+ scSpanMark = Nothing
182188 }
183189
184190----------------------------------------------------------------------------
185191-- Internal functions
186192
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+
187210-- | Output a fixed 'Text' fragment. The argument may not contain any line
188211-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
189212-- keywords and pipes @|@ in functional dependencies.
@@ -195,7 +218,15 @@ txt ::
195218 -- | 'Text' to output
196219 Text ->
197220 R ()
198−txt = spit False False
221+txt = spit SimpleText
222+
223+-- | Similar to 'txt' but the text inserted this way is assumed to break the
224+-- “link” between the preceding atom and its pending comments.
225+interferingTxt ::
226+ -- | 'Text' to output
227+ Text ->
228+ R ()
229+interferingTxt = spit InterferingText
199230
200231-- | Output 'Outputable' fragment of AST. This can be used to output numeric
201232-- literals and similar. Everything that doesn't have inner structure but
@@ -204,48 +235,61 @@ atom ::
204235 Outputable a =>
205236 a ->
206237 R ()
207−atom = spit True False . T.pack . showOutputable
238+atom = spit Atom . T.pack . showOutputable
208239
209240-- | Low-level non-public helper to define 'txt' and 'atom'.
210241spit ::
211− -- | Should we mark the line as dirty?
212− Bool ->
213− -- | Used during outputting of pending comments?
214− Bool ->
242+ -- | Type of the thing to spit
243+ SpitType ->
215244 -- | 'Text' to output
216245 Text ->
217246 R ()
218−spit dirty printingComments txt' = do
247+spit _ "" = return ()
248+spit stype text = do
219249 requestedDel <- R (gets scRequestedDelimiter)
250+ pendingComments <- R (gets scPendingComments)
251+ when (stype == InterferingText && not (null pendingComments)) newline
220252 case requestedDel of
221253 RequestedNewline -> do
222254 R . modify $ \sc ->
223255 sc
224256 { scRequestedDelimiter = RequestedNothing
225257 }
226− if printingComments
227− then newlineRaw
228− else newline
258+ case stype of
259+ CommentPart -> newlineRaw
260+ _ -> newline
229261 _ -> return ()
230262 R $ do
231263 i <- asks rcIndent
232264 c <- gets scColumn
233− let spaces =
234− if c < i
235− then T.replicate (i - c) " "
236− else bool mempty " " (requestedDel == RequestedSpace)
237− indentedTxt = spaces <> txt'
265+ closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans
266+ let indentedTxt = spaces <> text
267+ spaces = T.replicate spacesN " "
268+ spacesN =
269+ if c == 0
270+ then i
271+ else bool 0 1 (requestedDel == RequestedSpace)
238272 modify $ \sc ->
239273 sc
240274 { scBuilder = scBuilder sc <> fromText indentedTxt,
241275 scColumn = scColumn sc + T.length indentedTxt,
242− scDirtyLine = scDirtyLine sc || dirty,
276+ scIndent =
277+ if c == 0
278+ then i
279+ else scIndent sc,
280+ scThisLineSpans =
281+ let xs = scThisLineSpans sc
282+ in case stype of
283+ Atom -> case closestEnclosing of
284+ Nothing -> xs
285+ Just x -> x : xs
286+ _ -> xs,
243287 scRequestedDelimiter = RequestedNothing,
244− scLastCommentSpan =
288+ scSpanMark =
245289 -- If there are pending comments, do not reset last comment
246290 -- location.
247− if printingComments || (not . null . scPendingComments) sc
248− then scLastCommentSpan sc
291+ if (stype == CommentPart) || (not . null . scPendingComments) sc
292+ then scSpanMark sc
249293 else Nothing
250294 }
251295
@@ -276,21 +320,22 @@ space = R . modify $ \sc ->
276320-- hard to output more than one blank newline in a row.
277321newline :: R ()
278322newline = do
323+ indent <- R (gets scIndent)
279324 cs <- reverse <$> R (gets scPendingComments)
280325 case cs of
281326 [] -> newlineRaw
282− ((position, _, _) : _) -> do
327+ ((position, _) : _) -> do
283328 case position of
284329 OnTheSameLine -> space
285330 OnNextLine -> newlineRaw
286− R . forM_ cs $ \(_, indent, txt') ->
331+ R . forM_ cs $ \(_, text) ->
287332 let modRC rc =
288333 rc
289334 { rcIndent = indent
290335 }
291336 R m = do
292− unless (T.null txt') $
293− spit False True txt'
337+ unless (T.null text) $
338+ spit CommentPart text
294339 newlineRaw
295340 in local modRC m
296341 R . modify $ \sc ->
@@ -311,7 +356,8 @@ newlineRaw = R . modify $ \sc ->
311356 VeryBeginning -> builderSoFar
312357 _ -> builderSoFar <> "\n",
313358 scColumn = 0,
314− scDirtyLine = False,
359+ scIndent = 0,
360+ scThisLineSpans = [],
315361 scRequestedDelimiter = case scRequestedDelimiter sc of
316362 AfterNewline -> RequestedNewline
317363 RequestedNewline -> RequestedNewline
@@ -319,14 +365,9 @@ newlineRaw = R . modify $ \sc ->
319365 _ -> AfterNewline
320366 }
321367
322−-- | Check if the current line is “dirty”, that is, there is something on it
323−-- that can have comments attached to it.
324−isLineDirty :: R Bool
325−isLineDirty = R (gets scDirtyLine)
326−
327368-- | Return 'True' if we should print record dot syntax.
328369useRecordDot :: R Bool
329−useRecordDot = R $ asks rcUseRecDot
370+useRecordDot = R (asks rcUseRecDot)
330371
331372-- | Increase indentation level by one indentation step for the inner
332373-- computation. 'inci' should be used when a part of code must be more
@@ -343,8 +384,7 @@ inci (R m) = R (local modRC m)
343384
344385-- | Set indentation level for the inner computation equal to current
345386-- column. This makes sure that the entire inner block is uniformly
346−-- \"shifted\" to the right. Only works (and makes sense) when enclosing
347−-- layout is multi-line.
387+-- \"shifted\" to the right.
348388sitcc :: R () -> R ()
349389sitcc (R m) = do
350390 requestedDel <- R (gets scRequestedDelimiter)
@@ -352,16 +392,9 @@ sitcc (R m) = do
352392 c <- R (gets scColumn)
353393 let modRC rc =
354394 rc
355− { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
395+ { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))
356396 }
357− vlayout (R m) . R $ do
358− modify $ \sc ->
359− sc
360− { scRequestedDelimiter = case requestedDel of
361− RequestedSpace -> RequestedNothing
362− other -> other
363− }
364− local modRC m
397+ R (local modRC m)
365398
366399-- | Set 'Layout' for internal computation.
367400enterLayout :: Layout -> R () -> R ()
@@ -402,11 +435,10 @@ registerPendingCommentLine ::
402435 -- | 'Text' to output
403436 Text ->
404437 R ()
405−registerPendingCommentLine position txt' = R $ do
406− i <- asks rcIndent
438+registerPendingCommentLine position text = R $ do
407439 modify $ \sc ->
408440 sc
409− { scPendingComments = (position, i, txt') : scPendingComments sc
441+ { scPendingComments = (position, text) : scPendingComments sc
410442 }
411443
412444-- | Drop elements that begin before or at the same place as given
@@ -465,6 +497,29 @@ withEnclosingSpan spn (R m) = R (local modRC m)
465497 { rcEnclosingSpans = spn : rcEnclosingSpans rc
466498 }
467499
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+
468523-- | Haddock string style.
469524data HaddockStyle
470525 = -- | @-- |@
@@ -477,20 +532,18 @@ data HaddockStyle
477532 Named String
478533
479534-- | Set span of last output comment.
480−setLastCommentSpan ::
481− -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
482− Maybe HaddockStyle ->
483− -- | Location of last printed comment
484− RealSrcSpan ->
535+setSpanMark ::
536+ -- | Span mark to set
537+ SpanMark ->
485538 R ()
486−setLastCommentSpan mhStyle spn = R . modify $ \sc ->
539+setSpanMark spnMark = R . modify $ \sc ->
487540 sc
488− { scLastCommentSpan = Just (mhStyle, spn)
541+ { scSpanMark = Just spnMark
489542 }
490543
491544-- | Get span of last output comment.
492−getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
493−getLastCommentSpan = R (gets scLastCommentSpan)
545+getSpanMark :: R (Maybe SpanMark)
546+getSpanMark = R (gets scSpanMark)
494547
495548----------------------------------------------------------------------------
496549-- Annotations
@@ -514,7 +567,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
514567
515568-- | Return 'True' if we can use braces in this context.
516569canUseBraces :: R Bool
517−canUseBraces = R $ asks rcCanUseBraces
570+canUseBraces = R (asks rcCanUseBraces)
518571
519572----------------------------------------------------------------------------
520573-- Constants
src/Ormolu/Printer/Meat/Common.hs+13−10
@@ -17,7 +17,6 @@ where
1717
1818import Control.Monad
1919import Data.List (isPrefixOf)
20−import Data.Maybe (isJust)
2120import qualified Data.Text as T
2221import GHC hiding (GhcPs, IE)
2322import Name (nameStableString)
@@ -115,14 +114,14 @@ p_qualName mname occName = do
115114p_infixDefHelper ::
116115 -- | Whether to format in infix style
117116 Bool ->
118− -- | Indentation-bumping wrapper
119− (R () -> R ()) ->
117+ -- | Whether to bump indentation for arguments
118+ Bool ->
120119 -- | How to print the operator\/name
121120 R () ->
122121 -- | How to print the arguments
123122 [R ()] ->
124123 R ()
125−p_infixDefHelper isInfix inci' name args =
124+p_infixDefHelper isInfix indentArgs name args =
126125 case (isInfix, args) of
127126 (True, p0 : p1 : ps) -> do
128127 let parens' =
@@ -132,18 +131,18 @@ p_infixDefHelper isInfix inci' name args =
132131 parens' $ do
133132 p0
134133 breakpoint
135− inci $ sitcc $ do
134+ inci . sitcc $ do
136135 name
137136 space
138137 p1
139− unless (null ps) . inci' $ do
138+ unless (null ps) . inciIf indentArgs $ do
140139 breakpoint
141140 sitcc (sep breakpoint sitcc ps)
142141 (_, ps) -> do
143142 name
144143 unless (null ps) $ do
145144 breakpoint
146− inci' $ sitcc (sep breakpoint sitcc args)
145+ inciIf indentArgs $ sitcc (sep breakpoint sitcc args)
147146
148147-- | Print a Haddock.
149148p_hsDocString ::
@@ -155,7 +154,11 @@ p_hsDocString ::
155154 LHsDocString ->
156155 R ()
157156p_hsDocString hstyle needsNewline (L l str) = do
158− goesAfterComment <- isJust <$> getLastCommentSpan
157+ let isCommentSpan = \case
158+ HaddockSpan _ _ -> True
159+ CommentSpan _ -> True
160+ _ -> False
161+ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark
159162 -- Make sure the Haddock is separated by a newline from other comments.
160163 when goesAfterComment newline
161164 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do
@@ -174,8 +177,8 @@ p_hsDocString hstyle needsNewline (L l str) = do
174177 -- It's often the case that the comment itself doesn't have a span
175178 -- attached to it and instead its location can be obtained from
176179 -- nearest enclosing span.
177− getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))
178− RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
180+ getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)
181+ RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)
179182
180183-- | Print anchor of named doc section.
181184p_hsDocName :: String -> R ()
src/Ormolu/Printer/Meat/Declaration.hs+76−57
@@ -12,7 +12,7 @@ module Ormolu.Printer.Meat.Declaration
1212where
1313
1414import Data.List (sort)
15−import Data.List.NonEmpty ((<|), NonEmpty (..))
15+import Data.List.NonEmpty (NonEmpty (..), (<|))
1616import qualified Data.List.NonEmpty as NE
1717import GHC hiding (InlinePragma)
1818import OccName (occNameFS)
@@ -54,25 +54,27 @@ p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
5454p_hsDeclsRespectGrouping = p_hsDecls' Respect
5555
5656p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
57−p_hsDecls' grouping style decls = sepSemi id $
58− -- Return a list of rendered declarations, adding a newline to separate
59− -- groups.
60− case groupDecls decls of
61− [] -> []
62− (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
57+p_hsDecls' grouping style decls =
58+ sepSemi id $
59+ -- Return a list of rendered declarations, adding a newline to separate
60+ -- groups.
61+ case groupDecls decls of
62+ [] -> []
63+ (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
6364 where
6465 renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
6566 renderGroupWithPrev prev curr =
6667 -- We can omit a blank line when the user didn't add one, but we must
6768 -- ensure we always add blank lines around documented declarations
68− if or
69− [ grouping == Disregard,
70− separatedByBlank getLoc prev curr,
71− isDocumented prev,
72− isDocumented curr
73− ]
74− then breakpoint : renderGroup curr
75− else renderGroup curr
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
7678
7779-- | Is a declaration group documented?
7880isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
@@ -83,9 +85,6 @@ isDocumented = any (isHaddock . unLoc)
8385 isHaddock _ = False
8486
8587-- | Group relevant declarations together.
86−--
87−-- Add a declaration to a group iff it is relevant to either the first or
88−-- the last declaration of the group.
8988groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
9089groupDecls [] = []
9190groupDecls (l@(L _ DocNext) : xs) =
@@ -94,18 +93,13 @@ groupDecls (l@(L _ DocNext) : xs) =
9493 case groupDecls xs of
9594 [] -> [l :| []]
9695 (x : xs') -> (l <| x) : xs'
97−groupDecls (lhdr : xs) =
98− let -- Pick the first decl as the group header
99− hdr = unLoc lhdr
100− -- Zip rest of the decls with their previous decl
101− zipped = zip (lhdr : xs) xs
102− -- Pick decls from the tail if they are relevant to the group header
103− -- or the previous decl.
104− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
105− let relevantToHdr = groupedDecls hdr cur
106− relevantToPrev = groupedDecls prev cur
107− in relevantToHdr || relevantToPrev
108− in (lhdr :| map snd grp) : groupDecls (map snd rest)
96+groupDecls (header : xs) =
97+ let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->
98+ let relevantToHdr = groupedDecls header current
99+ relevantToPrev = groupedDecls previous current
100+ isDeclSeries = declSeries previous current
101+ in isDeclSeries || relevantToHdr || relevantToPrev
102+ in (header :| map snd grp) : groupDecls (map snd rest)
109103
110104p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
111105p_hsDecl style = \case
@@ -164,35 +158,54 @@ p_instDecl style = \case
164158
165159p_derivDecl :: DerivDecl GhcPs -> R ()
166160p_derivDecl = \case
167− d@DerivDecl {..} -> p_standaloneDerivDecl d
161+ d@DerivDecl {} -> p_standaloneDerivDecl d
168162 XDerivDecl x -> noExtCon x
169163
170164-- | Determine if these declarations should be grouped together.
171165groupedDecls ::
172− HsDecl GhcPs ->
173− HsDecl GhcPs ->
166+ LHsDecl GhcPs ->
167+ LHsDecl GhcPs ->
174168 Bool
175−groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
176−groupedDecls (TypeSignature ns) (DefaultSignature ns') = ns `intersects` ns'
177−groupedDecls (DefaultSignature ns) (TypeSignature ns') = ns `intersects` ns'
178−groupedDecls (DefaultSignature ns) (FunctionBody ns') = ns `intersects` ns'
179−groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
180−groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
181−groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
182−groupedDecls (DataDeclaration n) x
183− | Just ns <- isPragma x =
184− let f = occNameFS . rdrNameOcc in f n `elem` map f ns
185−groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
186−groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
187−groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'
188−groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns
189−groupedDecls (KindSignature n) (DataDeclaration n') = n == n'
190−groupedDecls (KindSignature n) (ClassDeclaration n') = n == n'
191−groupedDecls (KindSignature n) (FamilyDeclaration n') = n == n'
192−-- This looks only at Haddocks, normal comments are handled elsewhere
193−groupedDecls DocNext _ = True
194−groupedDecls _ DocPrev = True
195−groupedDecls _ _ = False
169+groupedDecls (L l_x x') (L l_y y') =
170+ case (x', y') of
171+ (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'
172+ (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'
173+ (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'
174+ (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'
175+ (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'
176+ (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
177+ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns
178+ (DataDeclaration n, x)
179+ | Just ns <- isPragma x ->
180+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns
181+ (x, y)
182+ | Just ns <- isPragma x,
183+ Just ns' <- isPragma y ->
184+ ns `intersects` ns'
185+ (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'
186+ (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
187+ (PatternSignature ns, Pattern n) -> n `elem` ns
188+ (KindSignature n, DataDeclaration n') -> n == n'
189+ (KindSignature n, ClassDeclaration n') -> n == n'
190+ (KindSignature n, FamilyDeclaration n') -> n == n'
191+ -- Special case for TH splices, we look at locations
192+ (Splice, Splice) -> not (separatedByBlank id l_x l_y)
193+ -- This looks only at Haddocks, normal comments are handled elsewhere
194+ (DocNext, _) -> True
195+ (_, DocPrev) -> True
196+ _ -> False
197+
198+-- | Detect declaration series that should not have blanks between them.
199+declSeries ::
200+ LHsDecl GhcPs ->
201+ LHsDecl GhcPs ->
202+ Bool
203+declSeries (L _ x) (L _ y) =
204+ case (x, y) of
205+ ( SigD NoExtField (TypeSig NoExtField _ _),
206+ SigD NoExtField (TypeSig NoExtField _ _)
207+ ) -> True
208+ _ -> False
196209
197210intersects :: Ord a => [a] -> [a] -> Bool
198211intersects a b = go (sort a) (sort b)
@@ -217,6 +230,11 @@ isPragma = \case
217230 WarningPragma n -> Just n
218231 _ -> Nothing
219232
233+-- Declarations that do not refer to names
234+
235+pattern Splice :: HsDecl GhcPs
236+pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)
237+
220238-- Declarations referring to a single name
221239
222240pattern
@@ -281,9 +299,10 @@ patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc
281299patSigRdrNames _ = Nothing
282300
283301warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
284−warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case
285− L _ (Warning NoExtField ns _) -> map unLoc ns
286− L _ (XWarnDecl x) -> noExtCon x
302+warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $
303+ flip concatMap ws $ \case
304+ L _ (Warning NoExtField ns _) -> map unLoc ns
305+ L _ (XWarnDecl x) -> noExtCon x
287306warnSigRdrNames _ = Nothing
288307
289308patBindNames :: Pat GhcPs -> [RdrName]
src/Ormolu/Printer/Meat/Declaration.hs-boot−1
@@ -9,5 +9,4 @@ import Ormolu.Printer.Combinators
99import Ormolu.Printer.Meat.Common
1010
1111p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12−
1312p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
src/Ormolu/Printer/Meat/Declaration/Class.hs+2−2
@@ -58,7 +58,7 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
5858 switchLayout signatureSpans $
5959 p_infixDefHelper
6060 (isInfix fixity)
61− inci
61+ True
6262 (p_rdrName name)
6363 (located' p_hsTyVarBndr <$> hsq_explicit)
6464 inci (p_classFundeps fdeps)
@@ -82,7 +82,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do
8282 breakpoint
8383 txt "|"
8484 space
85− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps
85+ inci $ sep commaDel (sitcc . located' p_funDep) fdeps
8686
8787p_funDep :: FunDep (Located RdrName) -> R ()
8888p_funDep (before, after) = do
src/Ormolu/Printer/Meat/Declaration/Data.hs+54−29
@@ -41,7 +41,7 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
4141 inci $
4242 p_infixDefHelper
4343 (isInfix fixity)
44− inci
44+ True
4545 (p_rdrName name)
4646 (located' p_hsType <$> tpats)
4747 case dd_kindSig of
@@ -59,25 +59,37 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
5959 breakpoint
6060 txt "where"
6161 breakpoint
62− sepSemi (located' p_conDecl) dd_cons
63− else switchLayout (getLoc name : (getLoc <$> dd_cons))
64− $ inci
65− $ do
66− breakpoint
67− txt "="
68− space
69− let s =
70− vlayout
71− (space >> txt "|" >> space)
72− (newline >> txt "|" >> space)
73− sep s (sitcc . located' p_conDecl) dd_cons
62+ sepSemi (located' (p_conDecl False)) dd_cons
63+ else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do
64+ let singleConstRec = isSingleConstRec dd_cons
65+ if singleConstRec
66+ then space
67+ else
68+ if hasHaddocks dd_cons
69+ then newline
70+ else breakpoint
71+ equals
72+ space
73+ layout <- getLayout
74+ let s =
75+ if layout == MultiLine || hasHaddocks dd_cons
76+ then newline >> txt "|" >> space
77+ else space >> txt "|" >> space
78+ sitcc' =
79+ if singleConstRec
80+ then id
81+ else sitcc
82+ sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
7483 unless (null $ unLoc dd_derivs) breakpoint
7584 inci . located dd_derivs $ \xs ->
7685 sep newline (located' p_hsDerivingClause) xs
7786p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x
7887
79−p_conDecl :: ConDecl GhcPs -> R ()
80−p_conDecl = \case
88+p_conDecl ::
89+ Bool ->
90+ ConDecl GhcPs ->
91+ R ()
92+p_conDecl singleConstRec = \case
8193 ConDeclGADT {..} -> do
8294 mapM_ (p_hsDocString Pipe True) con_doc
8395 let conDeclSpn =
@@ -92,11 +104,10 @@ p_conDecl = \case
92104 (c : cs) -> do
93105 p_rdrName c
94106 unless (null cs) . inci $ do
95− comma
96− breakpoint
97− sitcc $ sep (comma >> breakpoint) p_rdrName cs
98− space
107+ commaDel
108+ sep commaDel p_rdrName cs
99109 inci $ do
110+ space
100111 txt "::"
101112 let interArgBreak =
102113 if hasDocStrings (unLoc con_res_ty)
@@ -124,26 +135,27 @@ p_conDecl = \case
124135 p_hsType (unLoc con_res_ty)
125136 ConDeclH98 {..} -> do
126137 mapM_ (p_hsDocString Pipe True) con_doc
127− let conDeclSpn =
128− [getLoc con_name]
129− <> [getLoc con_forall]
138+ let conDeclWithContextSpn =
139+ [getLoc con_forall]
130140 <> fmap getLoc con_ex_tvs
131141 <> maybeToList (fmap getLoc con_mb_cxt)
132− <> conArgsSpans con_args
133− switchLayout conDeclSpn $ do
142+ <> conDeclSpn
143+ conDeclSpn =
144+ getLoc con_name : conArgsSpans con_args
145+ switchLayout conDeclWithContextSpn $ do
134146 when (unLoc con_forall) $ do
135147 p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs
136148 breakpoint
137149 forM_ con_mb_cxt p_lhsContext
138− case con_args of
150+ switchLayout conDeclSpn $ case con_args of
139151 PrefixCon xs -> do
140152 p_rdrName con_name
141153 unless (null xs) breakpoint
142− inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs
154+ inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs
143155 RecCon l -> do
144156 p_rdrName con_name
145157 breakpoint
146− inci $ located l p_conDeclFields
158+ inciIf (not singleConstRec) (located l p_conDeclFields)
147159 InfixCon x y -> do
148160 located x p_hsType
149161 breakpoint
@@ -192,9 +204,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
192204 let derivingWhat = located deriv_clause_tys $ \case
193205 [] -> txt "()"
194206 xs ->
195− parens N . sitcc $
207+ parens N $
196208 sep
197− (comma >> breakpoint)
209+ commaDel
198210 (sitcc . located' p_hsType . hsib_body)
199211 xs
200212 space
@@ -234,3 +246,16 @@ isInfix :: LexicalFixity -> Bool
234246isInfix = \case
235247 Infix -> True
236248 Prefix -> False
249+
250+isSingleConstRec :: [LConDecl GhcPs] -> Bool
251+isSingleConstRec [(L _ ConDeclH98 {..})] =
252+ case con_args of
253+ RecCon _ -> True
254+ _ -> False
255+isSingleConstRec _ = False
256+
257+hasHaddocks :: [LConDecl GhcPs] -> Bool
258+hasHaddocks = any (f . unLoc)
259+ where
260+ f ConDeclH98 {..} = isJust con_doc
261+ f _ = False
src/Ormolu/Printer/Meat/Declaration/Default.hs+2−2
@@ -15,6 +15,6 @@ p_defaultDecl = \case
1515 DefaultDecl NoExtField ts -> do
1616 txt "default"
1717 breakpoint
18− inci . parens N . sitcc $
19− sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
18+ inci . parens N $
19+ sep commaDel (sitcc . located' p_hsType) ts
2020 XDefaultDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Instance.hs+5−9
@@ -32,9 +32,7 @@ p_standaloneDerivDecl DerivDecl {..} = do
3232 txt "instance"
3333 breakpoint
3434 match_overlap_mode deriv_overlap_mode breakpoint
35− if toIndent
36− then inci typesAfterInstance
37− else typesAfterInstance
35+ inciIf toIndent typesAfterInstance
3836 txt "deriving"
3937 space
4038 case deriv_strategy of
@@ -90,12 +88,10 @@ p_clsInstDecl = \case
9088 unless (null allDecls) $ do
9189 breakpoint
9290 txt "where"
93− unless (null allDecls)
94− $ inci
95− $ do
96− -- Ensure whitespace is added after where clause.
97− breakpoint
98− dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
91+ unless (null allDecls) . inci $ do
92+ -- Ensure whitespace is added after where clause.
93+ breakpoint
94+ dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
9995 XHsImplicitBndrs x -> noExtCon x
10096 XClsInstDecl x -> noExtCon x
10197
src/Ormolu/Printer/Meat/Declaration/Rule.hs+2−2
@@ -18,7 +18,7 @@ import Ormolu.Printer.Meat.Type
1818p_ruleDecls :: RuleDecls GhcPs -> R ()
1919p_ruleDecls = \case
2020 HsRules NoExtField _ xs ->
21− pragma "RULES" . sitcc $
21+ pragma "RULES" $
2222 sep breakpoint (sitcc . located' p_ruleDecl) xs
2323 XRuleDecls x -> noExtCon x
2424
@@ -43,7 +43,7 @@ p_ruleDecl = \case
4343 inci $ do
4444 located lhs p_hsExpr
4545 space
46− txt "="
46+ equals
4747 inci $ do
4848 breakpoint
4949 located rhs p_hsExpr
src/Ormolu/Printer/Meat/Declaration/Signature.hs+29−27
@@ -14,7 +14,6 @@ where
1414import BasicTypes
1515import BooleanFormula
1616import Control.Monad
17−import Data.Bool (bool)
1817import GHC
1918import Ormolu.Printer.Combinators
2019import Ormolu.Printer.Meat.Common
@@ -48,24 +47,22 @@ p_typeSig indentTail (n : ns) hswc = do
4847 p_rdrName n
4948 if null ns
5049 then p_typeAscription hswc
51− else bool id inci indentTail $ do
52− comma
53− breakpoint
54− sep (comma >> breakpoint) p_rdrName ns
50+ else inciIf indentTail $ do
51+ commaDel
52+ sep commaDel p_rdrName ns
5553 p_typeAscription hswc
5654
5755p_typeAscription ::
5856 LHsSigWcType GhcPs ->
5957 R ()
60−p_typeAscription HsWC {..} = do
58+p_typeAscription HsWC {..} = inci $ do
6159 space
62− inci $ do
63− txt "::"
64− let t = hsib_body hswc_body
65− if hasDocStrings (unLoc t)
66− then newline
67− else breakpoint
68− located t p_hsType
60+ txt "::"
61+ let t = hsib_body hswc_body
62+ if hasDocStrings (unLoc t)
63+ then newline
64+ else breakpoint
65+ located t p_hsType
6966p_typeAscription (XHsWildCardBndrs x) = noExtCon x
7067
7168p_patSynSig ::
@@ -74,7 +71,11 @@ p_patSynSig ::
7471 R ()
7572p_patSynSig names hsib = do
7673 txt "pattern"
77− let body = p_typeSig False names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
74+ let body =
75+ p_typeSig
76+ False
77+ names
78+ HsWC {hswc_ext = NoExtField, hswc_body = hsib}
7879 if length names > 1
7980 then breakpoint >> inci body
8081 else space >> body
@@ -103,7 +104,7 @@ p_fixSig = \case
103104 space
104105 atom n
105106 space
106− sitcc $ sep (comma >> breakpoint) p_rdrName names
107+ sitcc $ sep commaDel p_rdrName names
107108 XFixitySig x -> noExtCon x
108109
109110p_inlineSig ::
@@ -142,7 +143,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do
142143 space
143144 txt "::"
144145 breakpoint
145− inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts
146+ inci $ sep commaDel (located' p_hsType . hsib_body) ts
146147
147148p_inlineSpec :: InlineSpec -> R ()
148149p_inlineSpec = \case
@@ -186,13 +187,13 @@ p_booleanFormula = \case
186187 And xs ->
187188 sitcc $
188189 sep
189− (comma >> breakpoint)
190+ commaDel
190191 (located' p_booleanFormula)
191192 xs
192193 Or xs ->
193194 sitcc $
194195 sep
195− (breakpoint >> txt "| ")
196+ (breakpoint >> txt "|" >> space)
196197 (located' p_booleanFormula)
197198 xs
198199 Parens l -> located l (parens N . p_booleanFormula)
@@ -206,7 +207,7 @@ p_completeSig ::
206207p_completeSig cs' mty =
207208 located cs' $ \cs ->
208209 pragma "COMPLETE" . inci $ do
209− sitcc $ sep (comma >> breakpoint) p_rdrName cs
210+ sep commaDel p_rdrName cs
210211 forM_ mty $ \ty -> do
211212 space
212213 txt "::"
@@ -223,12 +224,13 @@ p_sccSig loc literal = pragma "SCC" . inci $ do
223224p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
224225p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do
225226 txt "type"
226− space
227− p_rdrName name
228− space
229− txt "::"
230− breakpoint
231− inci $ case bndrs of
232− HsIB NoExtField sig -> located sig p_hsType
233− XHsImplicitBndrs x -> noExtCon x
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
234236p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c
src/Ormolu/Printer/Meat/Declaration/Type.hs+5−3
@@ -28,11 +28,13 @@ p_synDecl name fixity HsQTvs {..} t = do
2828 switchLayout (getLoc name : map getLoc hsq_explicit) $
2929 p_infixDefHelper
3030 (case fixity of Infix -> True; _ -> False)
31− inci
31+ True
3232 (p_rdrName name)
3333 (map (located' p_hsTyVarBndr) hsq_explicit)
3434 space
35− txt "="
36− breakpoint
35+ equals
36+ if hasDocStrings (unLoc t)
37+ then newline
38+ else breakpoint
3739 inci (located t p_hsType)
3840p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+5−5
@@ -31,7 +31,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
3131 switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $
3232 p_infixDefHelper
3333 (isInfix fdFixity)
34− inci
34+ True
3535 (p_rdrName fdLName)
3636 (located' p_hsTyVarBndr <$> hsq_explicit)
3737 let resultSig = p_familyResultSigL fdResultSig
@@ -69,7 +69,7 @@ p_familyResultSigL l =
6969 breakpoint
7070 located k p_hsType
7171 TyVarSig NoExtField bndr -> Just $ do
72− txt "="
72+ equals
7373 breakpoint
7474 located bndr p_hsTyVarBndr
7575 XFamilyResultSig x ->
@@ -92,16 +92,16 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
9292 Just bndrs -> do
9393 p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
9494 breakpoint
95− (if null feqn_bndrs then id else inci) $ do
95+ inciIf (not $ null feqn_bndrs) $ do
9696 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
9797 switchLayout famLhsSpn $
9898 p_infixDefHelper
9999 (isInfix feqn_fixity)
100− inci
100+ True
101101 (p_rdrName feqn_tycon)
102102 (located' p_hsType . typeArgToType <$> feqn_pats)
103103 space
104− txt "="
104+ equals
105105 breakpoint
106106 inci (located feqn_rhs p_hsType)
107107p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
src/Ormolu/Printer/Meat/Declaration/Value.hs+210−172
@@ -1,4 +1,5 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RecordWildCards #-}
45{-# LANGUAGE TypeApplications #-}
@@ -21,12 +22,12 @@ import Data.Char (isPunctuation, isSymbol)
2122import Data.Data hiding (Infix, Prefix)
2223import Data.Functor ((<&>))
2324import Data.List (intersperse, sortOn)
24−import Data.List.NonEmpty ((<|), NonEmpty ((:|)))
25+import Data.List.NonEmpty (NonEmpty (..), (<|))
2526import qualified Data.List.NonEmpty as NE
2627import Data.Text (Text)
2728import qualified Data.Text as Text
2829import GHC
29−import OccName (mkVarOcc)
30+import OccName (occNameString)
3031import Ormolu.Printer.Combinators
3132import Ormolu.Printer.Internal
3233import Ormolu.Printer.Meat.Common
@@ -60,7 +61,7 @@ data Placement
6061 -- should use it and avoid bumping one level
6162 -- of indentation
6263 Hanging
63− deriving (Eq)
64+ deriving (Eq, Show)
6465
6566p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
6667p_valDecl = \case
@@ -179,25 +180,24 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
179180 NoSrcStrict -> return ()
180181 SrcStrict -> txt "!"
181182 SrcLazy -> txt "~"
182− inci' <- case NE.nonEmpty m_pats of
183− Nothing -> id <$ case style of
184− Function name -> p_rdrName name
185− _ -> return ()
183+ indentBody <- case NE.nonEmpty m_pats of
184+ Nothing ->
185+ False <$ case style of
186+ Function name -> p_rdrName name
187+ _ -> return ()
186188 Just ne_pats -> do
187− let combinedSpans =
188− combineSrcSpans' $
189− getLoc <$> ne_pats
190− inci' =
191− if isOneLineSpan combinedSpans
192− then id
193− else inci
189+ let combinedSpans = case style of
190+ Function name -> combineSrcSpans (getLoc name) patSpans
191+ _ -> patSpans
192+ patSpans = combineSrcSpans' (getLoc <$> ne_pats)
193+ indentBody = not (isOneLineSpan combinedSpans)
194194 switchLayout [combinedSpans] $ do
195195 let stdCase = sep breakpoint (located' p_pat) m_pats
196196 case style of
197197 Function name ->
198198 p_infixDefHelper
199199 isInfix
200− inci'
200+ indentBody
201201 (p_rdrName name)
202202 (located' p_pat <$> m_pats)
203203 PatternBind -> stdCase
@@ -212,40 +212,32 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
212212 when needsSpace space
213213 sitcc stdCase
214214 LambdaCase -> stdCase
215− return inci'
215+ return indentBody
216216 let -- Calculate position of end of patterns. This is useful when we decide
217217 -- about putting certain constructions in hanging positions.
218218 endOfPats = case NE.nonEmpty m_pats of
219219 Nothing -> case style of
220− Function name -> (Just . srcSpanEnd . getLoc) name
220+ Function name -> Just (getLoc name)
221221 _ -> Nothing
222− Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
222+ Just pats -> (Just . getLoc . NE.last) pats
223223 isCase = \case
224224 Case -> True
225225 LambdaCase -> True
226226 _ -> False
227− let hasGuards = withGuards grhssGRHSs
228− unless (length grhssGRHSs > 1) $
229− case style of
230− Function _ | hasGuards -> return ()
231− Function _ -> space >> txt "="
232− PatternBind -> space >> txt "="
233− s | isCase s && hasGuards -> return ()
234− _ -> space >> txt "->"
235− let grhssSpan =
227+ hasGuards = withGuards grhssGRHSs
228+ grhssSpan =
236229 combineSrcSpans' $
237230 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
238231 patGrhssSpan =
239232 maybe
240233 grhssSpan
241− (combineSrcSpans grhssSpan . srcLocSpan)
234+ (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)
242235 endOfPats
243236 placement =
244237 case endOfPats of
245238 Nothing -> blockPlacement placer grhssGRHSs
246239 Just spn ->
247− if isOneLineSpan
248− (mkSrcSpan spn (srcSpanStart grhssSpan))
240+ if onTheSameLine spn grhssSpan
249241 then blockPlacement placer grhssGRHSs
250242 else Normal
251243 p_body = do
@@ -261,7 +253,14 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
261253 txt "where"
262254 unless whereIsEmpty breakpoint
263255 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 "->"
265264 switchLayout [patGrhssSpan] $
266265 placeHanging placement p_body
267266 inci p_where
@@ -285,24 +284,24 @@ p_grhs' placer render style (GRHS NoExtField guards body) =
285284 xs -> do
286285 txt "|"
287286 space
288− sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
287+ sitcc (sep commaDel (sitcc . located' p_stmt) xs)
289288 space
290− txt $ case style of
291− EqualSign -> "="
292− RightArrow -> "->"
289+ inci $ case style of
290+ EqualSign -> equals
291+ RightArrow -> txt "->"
293292 placeHanging placement p_body
294293 where
295294 placement =
296295 case endOfGuards of
297296 Nothing -> placer (unLoc body)
298297 Just spn ->
299− if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
298+ if onTheSameLine spn (getLoc body)
300299 then placer (unLoc body)
301300 else Normal
302301 endOfGuards =
303302 case NE.nonEmpty guards of
304303 Nothing -> Nothing
305− Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
304+ Just gs -> (Just . getLoc . NE.last) gs
306305 p_body = located body render
307306p_grhs' _ _ _ (XGRHS x) = noExtCon x
308307
@@ -310,13 +309,14 @@ p_hsCmd :: HsCmd GhcPs -> R ()
310309p_hsCmd = \case
311310 HsCmdArrApp NoExtField body input arrType _ -> do
312311 located body p_hsExpr
313− space
314− case arrType of
315− HsFirstOrderApp -> txt "-<"
316− HsHigherOrderApp -> txt "-<<"
317− placeHanging (exprPlacement (unLoc input)) $
318− located input p_hsExpr
319− HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do
312+ breakpoint
313+ inci $ do
314+ case arrType of
315+ HsFirstOrderApp -> txt "-<"
316+ HsHigherOrderApp -> txt "-<<"
317+ placeHanging (exprPlacement (unLoc input)) $
318+ located input p_hsExpr
319+ HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do
320320 located form p_hsExpr
321321 unless (null cmds) $ do
322322 breakpoint
@@ -344,7 +344,7 @@ p_hsCmd = \case
344344 txt "do"
345345 newline
346346 inci . located es $
347− sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
347+ sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))
348348 HsCmdWrap {} -> notImplemented "HsCmdWrap"
349349 XCmd x -> noExtCon x
350350
@@ -353,6 +353,35 @@ p_hsCmdTop = \case
353353 HsCmdTop NoExtField cmd -> located cmd p_hsCmd
354354 XCmdTop x -> noExtCon x
355355
356+-- | Render an expression preserving blank lines between such consecutive
357+-- expressions found in the original source code.
358+withSpacing ::
359+ -- | Rendering function
360+ (a -> R ()) ->
361+ -- | Entity to render
362+ Located a ->
363+ R ()
364+withSpacing f l = located l $ \x -> do
365+ case getLoc l of
366+ UnhelpfulSpan _ -> f x
367+ RealSrcSpan currentSpn -> do
368+ getSpanMark >>= \case
369+ -- Spacing before comments will be handled by the code
370+ -- that prints comments, so we just have to deal with
371+ -- blank lines between statements here.
372+ Just (StatementSpan lastSpn) ->
373+ if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1
374+ then newline
375+ else return ()
376+ _ -> return ()
377+ f x
378+ -- In some cases the (f x) expression may insert a new mark. We want
379+ -- to be careful not to override comment marks.
380+ getSpanMark >>= \case
381+ Just (HaddockSpan _ _) -> return ()
382+ Just (CommentSpan _) -> return ()
383+ _ -> setSpanMark (StatementSpan currentSpn)
384+
356385p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
357386p_stmt = p_stmt' exprPlacement p_hsExpr
358387
@@ -424,7 +453,7 @@ p_stmt' placer render = \case
424453 RecStmt {..} -> do
425454 txt "rec"
426455 space
427− sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
456+ sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
428457 XStmtLR c -> noExtCon c
429458
430459gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
@@ -442,34 +471,31 @@ gatherStmtBlock (XParStmtBlock x) = noExtCon x
442471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
443472p_hsLocalBinds = \case
444473 HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
445− let ssStart =
446− either
447− (srcSpanStart . getLoc)
448− (srcSpanStart . getLoc)
449− items =
450− (Left <$> bagToList bag) ++ (Right <$> lsigs)
451− p_item (Left x) = located x p_valDecl
452− p_item (Right x) = located x p_sigDecl
453− -- Assigns 'False' to the last element, 'True' to the rest.
454− markInit :: [a] -> [(Bool, a)]
455− markInit [] = []
456− markInit [x] = [(False, x)]
457− markInit (x : xs) = (True, x) : markInit xs
458474 -- When in a single-line layout, there is a chance that the inner
459475 -- elements will also contain semicolons and they will confuse the
460476 -- parser. so we request braces around every element except the last.
461477 br <- layoutToBraces <$> getLayout
462− sitcc $
463− sepSemi
464− (\(m, i) -> (if m then br else id) $ p_item i)
465− (markInit $ sortOn ssStart items)
478+ let items =
479+ let injectLeft (L l x) = L l (Left x)
480+ injectRight (L l x) = L l (Right x)
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)
466492 HsValBinds NoExtField _ -> notImplemented "HsValBinds"
467493 HsIPBinds NoExtField (IPBinds NoExtField xs) ->
468494 -- Second argument of IPBind is always Left before type-checking.
469495 let p_ipBind (IPBind NoExtField (Left name) expr) = do
470496 atom name
471497 space
472− txt "="
498+ equals
473499 breakpoint
474500 useBraces $ inci $ located expr p_hsExpr
475501 p_ipBind (IPBind NoExtField (Right _) _) =
@@ -488,15 +514,12 @@ p_hsRecField HsRecField {..} = do
488514 p_rdrName hsRecFieldLbl
489515 unless hsRecPun $ do
490516 space
491− txt "="
492− let placement = exprPlacement (unLoc hsRecFieldArg)
493− placeHanging placement $ located hsRecFieldArg p_hsExpr
494−
495−p_hsTupArg :: HsTupArg GhcPs -> R ()
496−p_hsTupArg = \case
497− Present NoExtField x -> located x p_hsExpr
498− Missing NoExtField -> pure ()
499− XTupArg x -> noExtCon x
517+ equals
518+ let placement =
519+ if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)
520+ then exprPlacement (unLoc hsRecFieldArg)
521+ else Normal
522+ placeHanging placement (located hsRecFieldArg p_hsExpr)
500523
501524p_hsExpr :: HsExpr GhcPs -> R ()
502525p_hsExpr = p_hsExpr' N
@@ -561,23 +584,21 @@ p_hsExpr' s = \case
561584 -- do-block or case expression it is not a good idea. It seems
562585 -- to be safe to always bump indentation when the function
563586 -- expression is parenthesised.
564− indent =
587+ doIndent =
565588 case func of
566− L _ (HsPar NoExtField _) -> inci
567− L _ (HsAppType NoExtField _ _) -> inci
568− L _ (HsMultiIf NoExtField _) -> inci
569− L spn _ ->
570− if isOneLineSpan spn
571− then inci
572− else id
573− ub <- getLayout <&> \case
574− SingleLine -> useBraces
575− MultiLine -> id
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
576597 ub $ do
577598 located func (p_hsExpr' s)
578599 breakpoint
579− indent $ sep breakpoint (located' p_hsExpr) initp
580− indent $ do
600+ inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601+ inciIf doIndent $ do
581602 unless (null initp) breakpoint
582603 located lastp p_hsExpr
583604 Hanging -> do
@@ -592,10 +613,15 @@ p_hsExpr' s = \case
592613 breakpoint
593614 inci $ do
594615 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 ()
595621 located (hswc_body a) p_hsType
596622 OpApp NoExtField x op y -> do
597623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
598− p_exprOpTree True s (reassociateOpTree getOpName opTree)
624+ p_exprOpTree s (reassociateOpTree getOpName opTree)
599625 NegApp NoExtField e _ -> do
600626 txt "-"
601627 space
@@ -612,22 +638,27 @@ p_hsExpr' s = \case
612638 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
613639 unless (useRecordDot' && isRecordDot') breakpoint
614640 inci (located x p_hsExpr)
615− ExplicitTuple NoExtField args boxity -> do
641+ ExplicitTuple NoExtField args boxity ->
616642 let isSection = any (isMissing . unLoc) args
617643 isMissing = \case
618644 Missing NoExtField -> True
619645 _ -> False
620− let parens' =
646+ p_arg = \case
647+ Present NoExtField x -> located x p_hsExpr
648+ Missing NoExtField -> pure ()
649+ XTupArg x -> noExtCon x
650+ p_larg = sitcc . located' p_arg
651+ parens' =
621652 case boxity of
622653 Boxed -> parens
623654 Unboxed -> parensHash
624− if isSection
625− then
626− switchLayout [] . parens' s $
627− sep comma (located' p_hsTupArg) args
628− else
629− switchLayout (getLoc <$> args) . parens' s . sitcc $
630− sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
655+ in if isSection
656+ then
657+ switchLayout [] . parens' s $
658+ sep comma p_larg args
659+ else
660+ switchLayout (getLoc <$> args) . parens' s $
661+ sep commaDel p_larg args
631662 ExplicitSum NoExtField tag arity e ->
632663 p_unboxedSum N tag arity (located e p_hsExpr)
633664 HsCase NoExtField e mgroup ->
@@ -635,8 +666,9 @@ p_hsExpr' s = \case
635666 HsIf NoExtField _ if' then' else' ->
636667 p_if exprPlacement p_hsExpr if' then' else'
637668 HsMultiIf NoExtField guards -> do
638− txt "if "
639− inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
669+ txt "if"
670+ breakpoint
671+ inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
640672 HsLet NoExtField localBinds e ->
641673 p_let p_hsExpr localBinds e
642674 HsDo NoExtField ctx es -> do
@@ -646,17 +678,17 @@ p_hsExpr' s = \case
646678 ub <- layoutToBraces <$> getLayout
647679 inci $
648680 sepSemi
649− (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
681+ (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
650682 (unLoc es)
651− compBody = brackets N $ located es $ \xs -> do
683+ compBody = brackets N . located es $ \xs -> do
652684 let p_parBody =
653685 sep
654− (breakpoint >> txt "| ")
686+ (breakpoint >> txt "|" >> space)
655687 p_seqBody
656688 p_seqBody =
657689 sitcc
658690 . sep
659− (comma >> breakpoint)
691+ commaDel
660692 (located' (sitcc . p_stmt))
661693 stmts = init xs
662694 yield = last xs
@@ -677,8 +709,8 @@ p_hsExpr' s = \case
677709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
678710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
679711 ExplicitList _ _ xs ->
680− brackets s . sitcc $
681− sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
712+ brackets s $
713+ sep commaDel (sitcc . located' p_hsExpr) xs
682714 RecordCon {..} -> do
683715 located rcon_con_name atom
684716 breakpoint
@@ -694,8 +726,8 @@ p_hsExpr' s = \case
694726 case rec_dotdot of
695727 Just {} -> [txt ".."]
696728 Nothing -> []
697− inci . braces N . sitcc $
698− sep (comma >> breakpoint) sitcc (fields <> dotdot)
729+ inci . braces N $
730+ sep commaDel sitcc (fields <> dotdot)
699731 RecordUpd {..} -> do
700732 located rupd_expr p_hsExpr
701733 useRecordDot' <- useRecordDot
@@ -713,9 +745,9 @@ p_hsExpr' s = \case
713745 Unambiguous _ n -> n
714746 XAmbiguousFieldOcc x -> noExtCon x
715747 }
716− inci . braces N . sitcc $
748+ inci . braces N $
717749 sep
718− (comma >> breakpoint)
750+ commaDel
719751 (sitcc . located' (p_hsRecField . updName))
720752 rupd_flds
721753 ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
@@ -728,22 +760,22 @@ p_hsExpr' s = \case
728760 ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
729761 ArithSeq NoExtField _ x ->
730762 case x of
731− From from -> brackets s . sitcc $ do
763+ From from -> brackets s $ do
732764 located from p_hsExpr
733765 breakpoint
734766 txt ".."
735− FromThen from next -> brackets s . sitcc $ do
736− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
767+ FromThen from next -> brackets s $ do
768+ sep commaDel (located' p_hsExpr) [from, next]
737769 breakpoint
738770 txt ".."
739− FromTo from to -> brackets s . sitcc $ do
771+ FromTo from to -> brackets s $ do
740772 located from p_hsExpr
741773 breakpoint
742774 txt ".."
743775 space
744776 located to p_hsExpr
745− FromThenTo from next to -> brackets s . sitcc $ do
746− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
777+ FromThenTo from next to -> brackets s $ do
778+ sep commaDel (located' p_hsExpr) [from, next]
747779 breakpoint
748780 txt ".."
749781 space
@@ -793,7 +825,7 @@ p_patSynBind PSB {..} = do
793825 breakpoint
794826 located psb_def p_pat
795827 ImplicitBidirectional -> do
796− txt "="
828+ equals
797829 breakpoint
798830 located psb_def p_pat
799831 ExplicitBidirectional mgroup -> do
@@ -820,8 +852,8 @@ p_patSynBind PSB {..} = do
820852 inci $ do
821853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
822854 unless (null xs) breakpoint
823− braces N . sitcc $
824− sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
855+ braces N $
856+ sep commaDel (p_rdrName . recordPatSynPatVar) xs
825857 rhs
826858 InfixCon l r -> do
827859 switchLayout [getLoc l, getLoc r] $ do
@@ -875,10 +907,12 @@ p_if placer render if' then' else' = do
875907 breakpoint
876908 inci $ do
877909 txt "then"
910+ space
878911 located then' $ \x ->
879912 placeHanging (placer x) (render x)
880913 breakpoint
881914 txt "else"
915+ space
882916 located else' $ \x ->
883917 placeHanging (placer x) (render x)
884918
@@ -915,13 +949,13 @@ p_pat = \case
915949 txt "!"
916950 located pat p_pat
917951 ListPat NoExtField pats ->
918− brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
952+ brackets S $ sep commaDel (located' p_pat) pats
919953 TuplePat NoExtField pats boxing -> do
920− let f =
954+ let parens' =
921955 case boxing of
922956 Boxed -> parens S
923957 Unboxed -> parensHash S
924− f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
958+ parens' $ sep commaDel (sitcc . located' p_pat) pats
925959 SumPat NoExtField pat tag arity ->
926960 p_unboxedSum S tag arity (located pat p_pat)
927961 ConPatIn pat details ->
@@ -937,7 +971,7 @@ p_pat = \case
937971 let f = \case
938972 Nothing -> txt ".."
939973 Just x -> located x p_pat_hsRecField
940− inci . braces N . sitcc . sep (comma >> breakpoint) f $
974+ inci . braces N . sep commaDel f $
941975 case dotdot of
942976 Nothing -> Just <$> fields
943977 Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
@@ -978,7 +1012,7 @@ p_pat_hsRecField HsRecField {..} = do
9781012 p_rdrName (rdrNameFieldOcc x)
9791013 unless hsRecPun $ do
9801014 space
981− txt "="
1015+ equals
9821016 breakpoint
9831017 inci (located hsRecFieldArg p_pat)
9841018
@@ -987,17 +1021,15 @@ p_unboxedSum s tag arity m = do
9871021 let before = tag - 1
9881022 after = arity - before - 1
9891023 args = replicate before Nothing <> [Just m] <> replicate after Nothing
990− f (x, i) = do
991− let isFirst = i == 0
992− isLast = i == arity - 1
1024+ f x =
9931025 case x :: Maybe (R ()) of
9941026 Nothing ->
995− unless (isFirst || isLast) space
1027+ space
9961028 Just m' -> do
997− unless isFirst space
1029+ space
9981030 m'
999− unless isLast space
1000− parensHash s $ sep (txt "|") f (zip args [0 ..])
1031+ space
1032+ parensHash s $ sep (txt "|") f args
10011033
10021034p_hsSplice :: HsSplice GhcPs -> R ()
10031035p_hsSplice = \case
@@ -1199,11 +1231,10 @@ exprPlacement = \case
11991231 HsCase NoExtField _ _ -> Hanging
12001232 HsDo NoExtField DoExpr _ -> Hanging
12011233 HsDo NoExtField MDoExpr _ -> Hanging
1202− -- If the rightmost expression in an operator chain is hanging, make the
1203− -- whole block hanging; so that we can use the common @f = foo $ do@
1204− -- style.
1205− OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
1206− -- Same thing for function applications (usually with -XBlockArguments)
1234+ OpApp NoExtField _ op y ->
1235+ case (fmap getOpNameStr . getOpName . unLoc) op of
1236+ Just "$" -> exprPlacement (unLoc y)
1237+ _ -> Normal
12071238 HsApp NoExtField _ y -> exprPlacement (unLoc y)
12081239 HsProc NoExtField p _ ->
12091240 -- Indentation breaks if pattern is longer than one line and left
@@ -1229,15 +1260,16 @@ getOpName = \case
12291260 HsVar NoExtField (L _ a) -> Just a
12301261 _ -> Nothing
12311262
1263+getOpNameStr :: RdrName -> String
1264+getOpNameStr = occNameString . rdrNameOcc
1265+
12321266p_exprOpTree ::
1233− -- | Can use special handling of dollar?
1234− Bool ->
12351267 -- | Bracket style to use
12361268 BracketStyle ->
12371269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12381270 R ()
1239−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1240−p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1271+p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
1272+p_exprOpTree s (OpBranch x op y) = do
12411273 -- If the beginning of the first argument and the second argument are on
12421274 -- the same line, and the second argument has a hanging form, use hanging
12431275 -- placement.
@@ -1259,44 +1291,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12591291 MultiLine -> case placement of
12601292 Hanging -> useBraces
12611293 Normal -> dontUseBraces
1262− gotDollar = case getOpName (unLoc op) of
1263− Just rname -> mkVarOcc "$" == rdrNameOcc rname
1264− _ -> False
1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295+ gotDollar = opNameStr == Just "$"
1296+ gotColon = opNameStr == Just ":"
1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
12651298 lhs =
12661299 switchLayout [opTreeLoc x] $
1267− p_exprOpTree (not gotDollar) s x
1268− let p_op = located op (opWrapper . p_hsExpr)
1269− p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
1300+ p_exprOpTree s x
1301+ p_op = located op (opWrapper . p_hsExpr)
1302+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
12701303 isSection = case (opTreeLoc x, getLoc op) of
12711304 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
12721305 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
12731306 _ -> False
1307+ isDoBlock = \case
1308+ OpNode (L _ HsDo {}) -> True
1309+ _ -> False
12741310 useRecordDot' <- useRecordDot
1275− let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)
1276− if useRecordDot' && isRecordDot'
1277− then do
1278− lhs
1279− when isSection space
1280− p_op
1281− p_y
1282− else
1283− if isDollarSpecial
1284− && gotDollar
1285− && placement
1286− == Normal
1287− && isOneLineSpan (opTreeLoc x)
1288− then do
1289− useBraces lhs
1290− space
1291− p_op
1292− breakpoint
1293− inci p_y
1294− else do
1295− ub lhs
1296− placeHanging placement $ do
1297− p_op
1311+ if
1312+ | gotColon -> do
1313+ lhs
1314+ space
1315+ p_op
1316+ case placement of
1317+ Hanging -> do
12981318 space
12991319 p_y
1320+ Normal -> do
1321+ breakpoint
1322+ inciIf (isDoBlock y) p_y
1323+ | gotDollar
1324+ && isOneLineSpan (opTreeLoc x)
1325+ && placement == Normal -> do
1326+ useBraces lhs
1327+ space
1328+ p_op
1329+ breakpoint
1330+ inci p_y
1331+ | useRecordDot' && gotRecordDot -> do
1332+ lhs
1333+ when isSection space
1334+ p_op
1335+ p_y
1336+ | otherwise -> do
1337+ ub lhs
1338+ placeHanging placement $ do
1339+ p_op
1340+ space
1341+ p_y
13001342
13011343-- | Return 'True' if given expression is a record-dot operator expression.
13021344isRecordDot ::
@@ -1307,14 +1349,10 @@ isRecordDot ::
13071349 Bool
13081350isRecordDot op (RealSrcSpan ySpan) = case op of
13091351 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1310− isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
13111353 _ -> False
13121354isRecordDot _ _ = False
13131355
1314−-- | Check whether a given 'RdrName' is the dot operator.
1315−isDot :: RdrName -> Bool
1316−isDot name = rdrNameOcc name == mkVarOcc "."
1317−
13181356-- | Get annotations for the enclosing element.
13191357getEnclosingAnns :: R [AnnKeywordId]
13201358getEnclosingAnns = do
src/Ormolu/Printer/Meat/Declaration/Value.hs-boot−4
@@ -11,11 +11,7 @@ import GHC
1111import Ormolu.Printer.Combinators
1212
1313p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
14−
1514p_pat :: Pat GhcPs -> R ()
16−
1715p_hsExpr :: HsExpr GhcPs -> R ()
18−
1916p_hsSplice :: HsSplice GhcPs -> R ()
20−
2117p_stringLit :: String -> R ()
src/Ormolu/Printer/Meat/Declaration/Warning.hs+5−8
@@ -27,17 +27,14 @@ p_warnDecl (XWarnDecl x) = noExtCon x
2727p_moduleWarning :: WarningTxt -> R ()
2828p_moduleWarning wtxt = do
2929 let (pragmaText, lits) = warningText wtxt
30− switchLayout (getLoc <$> lits)
31− $ inci
32− $ pragma pragmaText (inci $ p_lits lits)
30+ inci $ pragma pragmaText $ inci $ p_lits lits
3331
3432p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
3533p_topLevelWarning fnames wtxt = do
3634 let (pragmaText, lits) = warningText wtxt
37− switchLayout (fmap getLoc fnames ++ fmap getLoc lits)
38− $ pragma pragmaText . inci
39− $ do
40− sitcc $ sep (comma >> breakpoint) p_rdrName fnames
35+ switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $
36+ pragma pragmaText . inci $ do
37+ sep commaDel p_rdrName fnames
4138 breakpoint
4239 p_lits lits
4340
@@ -49,4 +46,4 @@ warningText = \case
4946p_lits :: [Located StringLiteral] -> R ()
5047p_lits = \case
5148 [l] -> atom l
52− ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls
49+ ls -> brackets N $ sep commaDel atom ls
src/Ormolu/Printer/Meat/ImportExport.hs+26−20
@@ -13,6 +13,7 @@ import Control.Monad
1313import GHC
1414import Ormolu.Printer.Combinators
1515import Ormolu.Printer.Meat.Common
16+import Ormolu.Utils (RelativePos (..), attachRelativePos)
1617
1718p_hsmodExports :: [LIE GhcPs] -> R ()
1819p_hsmodExports [] = do
@@ -20,9 +21,12 @@ p_hsmodExports [] = do
2021 breakpoint'
2122 txt ")"
2223p_hsmodExports xs =
23− parens N . sitcc $ do
24+ parens N $ do
2425 layout <- getLayout
25− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
26+ sep
27+ breakpoint
28+ (\(p, l) -> sitcc (located l (p_lie layout p)))
29+ (attachRelativePos xs)
2630
2731p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
2832p_hsmodImport useQualifiedPost ImportDecl {..} = do
@@ -61,14 +65,17 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do
6165 Nothing -> return ()
6266 Just (_, L _ xs) -> do
6367 breakpoint
64− parens N . sitcc $ do
68+ parens N $ do
6569 layout <- getLayout
66− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
70+ sep
71+ breakpoint
72+ (\(p, l) -> sitcc (located l (p_lie layout p)))
73+ (attachRelativePos xs)
6774 newline
6875p_hsmodImport _ (XImportDecl x) = noExtCon x
6976
70−p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
71−p_lie encLayout (i, totalItems) = \case
77+p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
78+p_lie encLayout relativePos = \case
7279 IEVar NoExtField l1 -> do
7380 located l1 p_ieWrappedName
7481 p_comma
@@ -86,9 +93,8 @@ p_lie encLayout (i, totalItems) = \case
8693 inci $ do
8794 let names :: [R ()]
8895 names = located' p_ieWrappedName <$> xs
89− parens N . sitcc
90− $ sep (comma >> breakpoint) sitcc
91− $ case w of
96+ parens N . sep commaDel sitcc $
97+ case w of
9298 NoIEWildcard -> names
9399 IEWildcard n ->
94100 let (before, after) = splitAt n names
@@ -98,7 +104,11 @@ p_lie encLayout (i, totalItems) = \case
98104 located l1 p_hsmodName
99105 p_comma
100106 IEGroup NoExtField n str -> do
101− unless (i == 0) newline
107+ case relativePos of
108+ SinglePos -> return ()
109+ FirstPos -> return ()
110+ MiddlePos -> newline
111+ LastPos -> newline
102112 p_hsDocString (Asterisk n) False (noLoc str)
103113 IEDoc NoExtField str ->
104114 p_hsDocString Pipe False (noLoc str)
@@ -107,14 +117,10 @@ p_lie encLayout (i, totalItems) = \case
107117 where
108118 p_comma =
109119 case encLayout of
110− SingleLine -> unless (i + 1 == totalItems) comma
120+ SingleLine ->
121+ case relativePos of
122+ SinglePos -> return ()
123+ FirstPos -> comma
124+ MiddlePos -> comma
125+ LastPos -> return ()
111126 MultiLine -> comma
112−
113−-- | Attach positions to 'Located' things in a list.
114−attachPositions ::
115− [Located a] ->
116− [Located ((Int, Int), a)]
117−attachPositions xs =
118− let f i (L l x) = L l ((i, n), x)
119− n = length xs
120− in zipWith f [0 ..] xs
src/Ormolu/Printer/Meat/Module.hs+23−20
@@ -11,8 +11,10 @@ where
1111import Control.Monad
1212import qualified Data.Text as T
1313import GHC
14−import Ormolu.Imports
14+import Ormolu.Imports (normalizeImports)
15+import Ormolu.Parser.CommentStream
1516import Ormolu.Parser.Pragma
17+import Ormolu.Parser.Shebang
1618import Ormolu.Printer.Combinators
1719import Ormolu.Printer.Comments
1820import Ormolu.Printer.Meat.Common
@@ -23,28 +25,28 @@ import Ormolu.Printer.Meat.Pragma
2325
2426-- | Render a module.
2527p_hsModule ::
28+ -- | Stack header
29+ Maybe (RealLocated Comment) ->
2630 -- | Shebangs
27− [Located String] ->
28− -- | Pragmas
29− [Pragma] ->
31+ [Shebang] ->
32+ -- | Pragmas and the associated comments
33+ [([RealLocated Comment], Pragma)] ->
3034 -- | Whether to use postfix qualified imports
3135 Bool ->
3236 -- | AST to print
33− ParsedSource ->
37+ HsModule GhcPs ->
3438 R ()
35−p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do
36− -- If span of exports in multiline, the whole thing is multiline. This is
37− -- especially important because span of module itself always seems to have
38− -- length zero, so it's not reliable for layout selection.
39− let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
40− deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
41− spans' = exportSpans ++ deprecSpan ++ [moduleSpan]
42− switchLayout spans' $ do
43− forM_ shebangs $ \x ->
39+p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do
40+ let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
41+ exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
42+ switchLayout (deprecSpan <> exportSpans) $ do
43+ forM_ shebangs $ \(Shebang x) ->
4444 located x $ \shebang -> do
4545 txt (T.pack shebang)
4646 newline
47− spitStackHeader
47+ forM_ mstackHeader $ \(L spn comment) -> do
48+ spitCommentNow spn comment
49+ newline
4850 newline
4951 p_pragmas pragmas
5052 newline
@@ -54,19 +56,20 @@ p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do
5456 located hsmodName' $ \name -> do
5557 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
5658 p_hsmodName name
59+ breakpoint
5760 forM_ hsmodDeprecMessage $ \w -> do
58− breakpoint
5961 located' p_moduleWarning w
62+ breakpoint
6063 case hsmodExports of
6164 Nothing -> return ()
62− Just hsmodExports' -> do
65+ Just l -> do
66+ located l $ \exports -> do
67+ inci (p_hsmodExports exports)
6368 breakpoint
64− inci (p_hsmodExports (unLoc hsmodExports'))
65− breakpoint
6669 txt "where"
6770 newline
6871 newline
69− forM_ (sortImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
72+ forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
7073 newline
7174 switchLayout (getLoc <$> hsmodDecls) $ do
7275 p_hsDecls Free hsmodDecls
src/Ormolu/Printer/Meat/Pragma.hs+22−12
@@ -8,12 +8,16 @@ module Ormolu.Printer.Meat.Pragma
88 )
99where
1010
11+import Control.Monad
1112import Data.Char (isUpper)
13+import qualified Data.List as L
1214import Data.Maybe (listToMaybe)
13−import qualified Data.Set as S
1415import qualified Data.Text as T
16+import Ormolu.Parser.CommentStream
1517import Ormolu.Parser.Pragma (Pragma (..))
1618import Ormolu.Printer.Combinators
19+import Ormolu.Printer.Comments
20+import SrcLoc
1721
1822-- | Pragma classification.
1923data PragmaTy
@@ -42,25 +46,31 @@ data LanguagePragmaClass
4246 Final
4347 deriving (Eq, Ord)
4448
45−p_pragmas :: [Pragma] -> R ()
46−p_pragmas ps =
47− let prepare = concatMap $ \case
48− PragmaLanguage xs ->
49− let f x = (Language (classifyLanguagePragma x), x)
49+-- | Print a collection of 'Pragma's with their associated comments.
50+p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()
51+p_pragmas ps = do
52+ let prepare = L.sortOn snd . L.nub . concatMap analyze
53+ analyze = \case
54+ (cs, PragmaLanguage xs) ->
55+ let f x = (cs, (Language (classifyLanguagePragma x), x))
5056 in f <$> xs
51− PragmaOptionsGHC x -> [(OptionsGHC, x)]
52− PragmaOptionsHaddock x -> [(OptionsHaddock, x)]
53− in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
57+ (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]
58+ (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]
59+ forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->
60+ p_pragma cs pragmaTy x
5461
55−p_pragma :: PragmaTy -> String -> R ()
56−p_pragma ty c = do
62+p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()
63+p_pragma comments ty x = do
64+ forM_ comments $ \(L l comment) -> do
65+ spitCommentNow l comment
66+ newline
5767 txt "{-# "
5868 txt $ case ty of
5969 Language _ -> "LANGUAGE"
6070 OptionsGHC -> "OPTIONS_GHC"
6171 OptionsHaddock -> "OPTIONS_HADDOCK"
6272 space
63− txt (T.pack c)
73+ txt (T.pack x)
6474 txt " #-}"
6575 newline
6676
src/Ormolu/Printer/Meat/Type.hs+48−27
@@ -5,6 +5,7 @@
55-- | Rendering of types.
66module Ormolu.Printer.Meat.Type
77 ( p_hsType,
8+ p_hsTypePostDoc,
89 hasDocStrings,
910 p_hsContext,
1011 p_hsTyVarBndr,
@@ -23,14 +24,22 @@ import Ormolu.Printer.Operators
2324import Ormolu.Utils
2425
2526p_hsType :: HsType GhcPs -> R ()
26−p_hsType t = p_hsType' (hasDocStrings t) t
27+p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t
2728
28−p_hsType' :: Bool -> HsType GhcPs -> R ()
29−p_hsType' multilineArgs = \case
29+p_hsTypePostDoc :: HsType GhcPs -> R ()
30+p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t
31+
32+-- | How to render Haddocks associated with a type.
33+data TypeDocStyle
34+ = PipeStyle
35+ | CaretStyle
36+
37+p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()
38+p_hsType' multilineArgs docStyle = \case
3039 HsForAllTy NoExtField visibility bndrs t -> do
3140 p_forallBndrs visibility p_hsTyVarBndr bndrs
3241 interArgBreak
33− p_hsType' multilineArgs (unLoc t)
42+ p_hsTypeR (unLoc t)
3443 HsQualTy NoExtField qs t -> do
3544 located qs p_hsContext
3645 space
@@ -49,10 +58,20 @@ p_hsType' multilineArgs = \case
4958 _ -> return ()
5059 NotPromoted -> return ()
5160 p_rdrName n
52− HsAppTy NoExtField f x -> sitcc $ do
53− located f p_hsType
54− breakpoint
55− inci (located x p_hsType)
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
5675 HsAppKindTy _ ty kd -> sitcc $ do
5776 -- The first argument is the location of the "@..." part. Not 100% sure,
5877 -- but I think we can ignore it as long as we use 'located' on both the
@@ -79,10 +98,9 @@ p_hsType' multilineArgs = \case
7998 HsBoxedTuple -> parens N
8099 HsConstraintTuple -> parens N
81100 HsBoxedOrConstraintTuple -> parens N
82− in parens' . sitcc $
83− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
101+ in parens' $ sep commaDel (sitcc . located' p_hsType) xs
84102 HsSumTy NoExtField xs ->
85− parensHash N . sitcc $
103+ parensHash N $
86104 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
87105 HsOpTy NoExtField x op y ->
88106 sitcc $
@@ -99,14 +117,20 @@ p_hsType' multilineArgs = \case
99117 HsStarTy NoExtField _ -> txt "*"
100118 HsKindSig NoExtField t k -> sitcc $ do
101119 located t p_hsType
102− space -- FIXME
103− txt "::"
104120 space
121+ txt "::"
122+ breakpoint
105123 inci (located k p_hsType)
106124 HsSpliceTy NoExtField splice -> p_hsSplice splice
107− HsDocTy NoExtField t str -> do
108− p_hsDocString Pipe True str
109− located t p_hsType
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
110134 HsBangTy NoExtField (HsSrcBang _ u s) t -> do
111135 case u of
112136 SrcUnpack -> txt "{-# UNPACK #-}" >> space
@@ -129,14 +153,14 @@ p_hsType' multilineArgs = \case
129153 case (p, xs) of
130154 (IsPromoted, L _ t : _) | isPromoted t -> space
131155 _ -> return ()
132− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
156+ sep commaDel (sitcc . located' p_hsType) xs
133157 HsExplicitTupleTy NoExtField xs -> do
134158 txt "'"
135159 parens N $ do
136160 case xs of
137161 L _ t : _ | isPromoted t -> space
138162 _ -> return ()
139− sep (comma >> breakpoint) (located' p_hsType) xs
163+ sep commaDel (located' p_hsType) xs
140164 HsTyLit NoExtField t ->
141165 case t of
142166 HsStrTy (SourceText s) _ -> p_stringLit s
@@ -146,14 +170,14 @@ p_hsType' multilineArgs = \case
146170 where
147171 isPromoted = \case
148172 HsTyVar _ IsPromoted _ -> True
149− HsExplicitListTy {} -> True
150173 HsExplicitTupleTy {} -> True
174+ HsExplicitListTy {} -> True
151175 _ -> False
152176 interArgBreak =
153177 if multilineArgs
154178 then newline
155179 else breakpoint
156− p_hsTypeR = p_hsType' multilineArgs
180+ p_hsTypeR = p_hsType' multilineArgs docStyle
157181
158182-- | Return 'True' if at least one argument in 'HsType' has a doc string
159183-- attached to it.
@@ -167,9 +191,7 @@ p_hsContext :: HsContext GhcPs -> R ()
167191p_hsContext = \case
168192 [] -> txt "()"
169193 [x] -> located x p_hsType
170− xs ->
171− parens N . sitcc $
172− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
194+ xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs
173195
174196p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
175197p_hsTyVarBndr = \case
@@ -199,15 +221,14 @@ p_forallBndrs vis p tyvars =
199221
200222p_conDeclFields :: [LConDeclField GhcPs] -> R ()
201223p_conDeclFields xs =
202− braces N . sitcc $
203− sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
224+ braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
204225
205226p_conDeclField :: ConDeclField GhcPs -> R ()
206227p_conDeclField ConDeclField {..} = do
207228 mapM_ (p_hsDocString Pipe True) cd_fld_doc
208229 sitcc $
209230 sep
210− (comma >> breakpoint)
231+ commaDel
211232 (located' (p_rdrName . rdrNameFieldOcc))
212233 cd_fld_names
213234 space
@@ -249,6 +270,6 @@ tyVarToType = \case
249270 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
250271 -- long as 'tyVarToType' does not get applied to right-hand sides of
251272 -- declarations.
252− HsParTy NoExtField $ noLoc $
273+ HsParTy NoExtField . noLoc $
253274 HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
254275 XTyVarBndr x -> noExtCon x
src/Ormolu/Printer/Operators.hs+50−63
@@ -11,11 +11,12 @@ module Ormolu.Printer.Operators
1111where
1212
1313import Data.Function (on)
14−import Data.List
14+import qualified Data.List as L
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
1517import Data.Maybe (fromMaybe, mapMaybe)
16−import Data.Ord (Down (Down), comparing)
1718import GHC
18−import OccName (mkVarOcc)
19+import OccName (occNameString)
1920import Ormolu.Utils (unSrcSpan)
2021
2122-- | Intermediate representation of operator trees. It has two type
@@ -56,7 +57,7 @@ reassociateOpTree getOpName opTree =
5657reassociateOpTreeWith ::
5758 forall ty op.
5859 -- | Fixity map for operators
59− [(RdrName, Fixity)] ->
60+ Map String Fixity ->
6061 -- | How to get the name of an operator
6162 (op -> Maybe RdrName) ->
6263 -- | Original 'OpTree'
@@ -67,13 +68,13 @@ reassociateOpTreeWith fixityMap getOpName = go
6768 where
6869 fixityOf :: op -> Fixity
6970 fixityOf op = fromMaybe defaultFixity $ do
70− opName <- getOpName op
71− lookup opName fixityMap
71+ s <- occNameString . rdrNameOcc <$> getOpName op
72+ M.lookup s fixityMap
7273 -- Here, left branch is already associated and the root alongside with
7374 -- the right branch is right-associated. This function picks up one item
7475 -- from the right and inserts it correctly to the left.
7576 --
76− -- Also, we are using the 'compareFixity' function which returns if the
77+ -- Also, we are using the 'compareFixity' function which tells if the
7778 -- expression should associate to right.
7879 go :: OpTree ty op -> OpTree ty op
7980 -- base cases
@@ -93,6 +94,16 @@ reassociateOpTreeWith fixityMap getOpName = go
9394 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
9495 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
9596
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+
96107-- | Build a map of inferred 'Fixity's from an 'OpTree'.
97108buildFixityMap ::
98109 forall ty op.
@@ -101,23 +112,26 @@ buildFixityMap ::
101112 -- | Operator tree
102113 OpTree (Located ty) (Located op) ->
103114 -- | Fixity map
104− [(RdrName, Fixity)]
115+ Map String Fixity
105116buildFixityMap getOpName opTree =
106− concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
107− . zip [0 ..]
108− . groupBy (doubleWithinEps 0.00001 `on` snd)
109− . (overrides ++)
110− . modeScores
117+ addOverrides
118+ . M.fromList
119+ . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
120+ . zip [2 ..]
121+ . L.groupBy ((==) `on` snd)
122+ . selectScores
111123 $ score opTree
112124 where
113− -- Add a special case for ($), since it is pretty unlikely for someone
114− -- to override it.
115− overrides :: [(RdrName, Double)]
116− overrides =
117− [ (mkRdrUnqual $ mkVarOcc "$", -1)
118− ]
119− -- Assign scores to operators based on their location in the source.
120− score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]
125+ addOverrides :: Map String Fixity -> Map String Fixity
126+ addOverrides m =
127+ M.fromList
128+ [ ("$", fixity 0 InfixR),
129+ (":", fixity 1 InfixR),
130+ (".", fixity 100 InfixL)
131+ ]
132+ `M.union` m
133+ fixity = Fixity NoSourceText
134+ score :: OpTree (Located ty) (Located op) -> [(String, Score)]
121135 score (OpNode _) = []
122136 score (OpBranch l o r) = fromMaybe (score r) $ do
123137 -- If we fail to get any of these, 'defaultFixity' will be used by
@@ -127,48 +141,27 @@ buildFixityMap getOpName opTree =
127141 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
128142 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
129143 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
130− opName <- getOpName (unLoc o)
144+ opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
131145 let s
132− | le < ob =
133− -- if the operator is in the beginning of a line, assign
134− -- a score relative to its column within range [0, 1).
135− fromIntegral oc / fromIntegral (maxCol + 1)
136− | oe < rb =
137− -- if the operator is in the end of the line, assign the
138− -- score 1.
139− 1
140− | otherwise =
141− 2 -- otherwise, assign a high score.
146+ | le < ob = AtBeginning oc
147+ | oe < rb = AtEnd
148+ | otherwise = InBetween
142149 return $ (opName, s) : score r
143− -- Pick the most common score per 'RdrName'.
144− modeScores :: [(RdrName, Double)] -> [(RdrName, Double)]
145− modeScores =
146− sortOn snd
150+ selectScores :: [(String, Score)] -> [(String, Score)]
151+ selectScores =
152+ L.sortOn snd
147153 . mapMaybe
148154 ( \case
149155 [] -> Nothing
150− xs@((n, _) : _) -> Just (n, mode $ map snd xs)
156+ xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)
151157 )
152− . groupBy ((==) `on` fst)
153− . sort
154− -- Return the most common number, leaning to the smaller
155− -- one in case of a tie.
156− mode :: [Double] -> Double
157− mode =
158− head
159− . minimumBy (comparing (Down . length))
160− . groupBy (doubleWithinEps 0.0001)
161− . sort
162− -- The start column of the rightmost operator.
163− maxCol = go opTree
164− where
165− go (OpNode (L _ _)) = 0
166− go (OpBranch l (L o _) r) =
167− maximum
168− [ go l,
169− maybe 0 srcSpanStartCol (unSrcSpan o),
170− go r
171− ]
158+ . L.groupBy ((==) `on` fst)
159+ . L.sort
160+ selectScore :: [Score] -> Score
161+ selectScore xs =
162+ case filter (/= InBetween) xs of
163+ [] -> InBetween
164+ xs' -> maximum xs'
172165
173166----------------------------------------------------------------------------
174167-- Helpers
@@ -182,9 +175,3 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =
182175 OpBranch (OpNode l) lop (normalizeOpTree r)
183176normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
184177 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
185−
186−fixity :: Int -> FixityDirection -> Fixity
187−fixity = Fixity NoSourceText
188−
189−doubleWithinEps :: Double -> Double -> Double -> Bool
190−doubleWithinEps eps a b = abs (a - b) < eps
src/Ormolu/Processing/Common.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- | Common definitions for pre- and post- processing.
4+module Ormolu.Processing.Common
5+ ( OrmoluState (..),
6+ startDisabling,
7+ endDisabling,
8+ )
9+where
10+
11+import Data.String (IsString (..))
12+
13+-- | Ormolu state.
14+data OrmoluState
15+ = -- | Enabled
16+ OrmoluEnabled
17+ | -- | Disabled
18+ OrmoluDisabled
19+ deriving (Eq, Show)
20+
21+-- | Marker for the beginning of the region where Ormolu should be disabled.
22+startDisabling :: IsString s => s
23+startDisabling = "{- ORMOLU_DISABLE_START"
24+
25+-- | Marker for the end of the region where Ormolu should be disabled.
26+endDisabling :: IsString s => s
27+endDisabling = "ORMOLU_DISABLE_END -}"
src/Ormolu/Processing/Cpp.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- | Support for CPP.
4+module Ormolu.Processing.Cpp
5+ ( State (..),
6+ processLine,
7+ unmaskLine,
8+ )
9+where
10+
11+import Control.Monad
12+import Data.Char (isSpace)
13+import qualified Data.List as L
14+import Data.Maybe (isJust)
15+import Data.String
16+import Data.Text (Text)
17+import qualified Data.Text as T
18+
19+-- | State of the CPP processor.
20+data State
21+ = -- | Outside of CPP directives
22+ Outside
23+ | -- | In a conditional expression
24+ InConditional
25+ | -- | In a continuation (after @\\@)
26+ InContinuation
27+ deriving (Eq, Show)
28+
29+-- | Automatically mask the line when needed and update the 'State'.
30+processLine :: String -> State -> (String, State)
31+processLine line state
32+ | for "define " = (masked, state')
33+ | for "include " = (masked, state')
34+ | for "undef " = (masked, state')
35+ | for "ifdef " = (masked, InConditional)
36+ | for "ifndef " = (masked, InConditional)
37+ | for "if " = (masked, InConditional)
38+ | for "else" = (masked, InConditional)
39+ | for "elif" = (masked, InConditional)
40+ | for "endif" = (masked, state')
41+ | otherwise =
42+ case state of
43+ Outside -> (line, Outside)
44+ InConditional -> (masked, InConditional)
45+ InContinuation -> (masked, state')
46+ where
47+ for directive = isJust $ do
48+ s <- dropWhile isSpace <$> L.stripPrefix "#" line
49+ void (L.stripPrefix directive s)
50+ masked = maskLine line
51+ state' =
52+ if "\\" `L.isSuffixOf` line
53+ then InContinuation
54+ else Outside
55+
56+-- | Mask the given line.
57+maskLine :: String -> String
58+maskLine x = maskPrefix ++ x
59+
60+-- | If the given line is masked, unmask it. Otherwise return the line
61+-- unchanged.
62+unmaskLine :: Text -> Text
63+unmaskLine x =
64+ case T.stripPrefix maskPrefix (T.stripStart x) of
65+ Nothing -> x
66+ Just x' -> x'
67+
68+-- | Mask prefix for CPP.
69+maskPrefix :: IsString s => s
70+maskPrefix = "-- ORMOLU_CPP_MASK"
src/Ormolu/Processing/Postprocess.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ViewPatterns #-}
3+
4+-- | Postprocessing for the results of printing.
5+module Ormolu.Processing.Postprocess
6+ ( postprocess,
7+ )
8+where
9+
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+import Ormolu.Processing.Common
13+import qualified Ormolu.Processing.Cpp as Cpp
14+
15+-- | Postprocess output of the formatter.
16+postprocess ::
17+ -- | Desired indentation level
18+ Int ->
19+ -- | Input to process
20+ Text ->
21+ Text
22+postprocess indent =
23+ T.unlines
24+ . fmap indentLine
25+ . fmap Cpp.unmaskLine
26+ . filter (not . magicComment)
27+ . T.lines
28+ where
29+ magicComment (T.stripStart -> x) =
30+ x == startDisabling || x == endDisabling
31+ indentLine x = T.replicate indent " " <> x
src/Ormolu/Processing/Preprocess.hsnew file+149
@@ -0,0 +1,149 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE RecordWildCards #-}
4+
5+-- | Preprocessing for input source code.
6+module Ormolu.Processing.Preprocess
7+ ( preprocess,
8+ )
9+where
10+
11+import Control.Monad
12+import Data.Char (isSpace)
13+import qualified Data.List as L
14+import Data.Maybe (isJust, maybeToList)
15+import FastString
16+import Ormolu.Config (RegionDeltas (..))
17+import Ormolu.Parser.Shebang (isShebang)
18+import Ormolu.Processing.Common
19+import qualified Ormolu.Processing.Cpp as Cpp
20+import SrcLoc
21+
22+-- | Transform given input possibly returning comments extracted from it.
23+-- This handles LINE pragmas, CPP, shebangs, and the magic comments for
24+-- enabling\/disabling of Ormolu.
25+preprocess ::
26+ -- | File name, just to use in the spans
27+ FilePath ->
28+ -- | Input to process
29+ String ->
30+ -- | Region deltas
31+ RegionDeltas ->
32+ -- | Literal prefix, pre-processed input, literal suffix, extra comments
33+ (String, String, String, [Located String])
34+preprocess path input RegionDeltas {..} =
35+ go 1 OrmoluEnabled Cpp.Outside id id regionLines
36+ where
37+ (prefixLines, otherLines) = splitAt regionPrefixLength (lines input)
38+ (regionLines, suffixLines) =
39+ let regionLength = length otherLines - regionSuffixLength
40+ in splitAt regionLength otherLines
41+ go !n ormoluState cppState inputSoFar csSoFar = \case
42+ [] ->
43+ let input' = unlines (inputSoFar [])
44+ in ( unlines prefixLines,
45+ case ormoluState of
46+ OrmoluEnabled -> input'
47+ OrmoluDisabled -> input' ++ endDisabling,
48+ unlines suffixLines,
49+ csSoFar []
50+ )
51+ (x : xs) ->
52+ let (x', ormoluState', cppState', cs) =
53+ processLine path n ormoluState cppState x
54+ in go
55+ (n + 1)
56+ ormoluState'
57+ cppState'
58+ (inputSoFar . (x' :))
59+ (csSoFar . (maybeToList cs ++))
60+ xs
61+
62+-- | Transform a given line possibly returning a comment extracted from it.
63+processLine ::
64+ -- | File name, just to use in the spans
65+ FilePath ->
66+ -- | Line number of this line
67+ Int ->
68+ -- | Whether Ormolu is currently enabled
69+ OrmoluState ->
70+ -- | CPP state
71+ Cpp.State ->
72+ -- | The actual line
73+ String ->
74+ -- | Adjusted line and possibly a comment extracted from it
75+ (String, OrmoluState, Cpp.State, Maybe (Located String))
76+processLine path n ormoluState Cpp.Outside line
77+ | "{-# LINE" `L.isPrefixOf` line =
78+ let (pragma, res) = getPragma line
79+ size = length pragma
80+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
81+ in (res, ormoluState, Cpp.Outside, Just (L ss pragma))
82+ | isOrmoluEnable line =
83+ case ormoluState of
84+ OrmoluEnabled ->
85+ (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
86+ OrmoluDisabled ->
87+ (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
88+ | isOrmoluDisable line =
89+ case ormoluState of
90+ OrmoluEnabled ->
91+ (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing)
92+ OrmoluDisabled ->
93+ (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing)
94+ | isShebang line =
95+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length line))
96+ in ("", ormoluState, Cpp.Outside, Just (L ss line))
97+ | otherwise =
98+ let (line', cppState') = Cpp.processLine line Cpp.Outside
99+ in (line', ormoluState, cppState', Nothing)
100+ where
101+ mkSrcLoc' = mkSrcLoc (mkFastString path) n
102+processLine _ _ ormoluState cppState line =
103+ let (line', cppState') = Cpp.processLine line cppState
104+ in (line', ormoluState, cppState', Nothing)
105+
106+-- | Take a line pragma and output its replacement (where line pragma is
107+-- replaced with spaces) and the contents of the pragma itself.
108+getPragma ::
109+ -- | Pragma line to analyze
110+ String ->
111+ -- | Contents of the pragma and its replacement line
112+ (String, String)
113+getPragma [] = error "Ormolu.Preprocess.getPragma: input must not be empty"
114+getPragma s@(x : xs)
115+ | "#-}" `L.isPrefixOf` s = ("#-}", " " ++ drop 3 s)
116+ | otherwise =
117+ let (prag, remline) = getPragma xs
118+ in (x : prag, ' ' : remline)
119+
120+-- | Canonical enable marker.
121+enableMarker :: String
122+enableMarker = "{- ORMOLU_ENABLE -}"
123+
124+-- | Canonical disable marker.
125+disableMarker :: String
126+disableMarker = "{- ORMOLU_DISABLE -}"
127+
128+-- | Return 'True' if the given string is an enabling marker.
129+isOrmoluEnable :: String -> Bool
130+isOrmoluEnable = magicComment "ORMOLU_ENABLE"
131+
132+-- | Return 'True' if the given string is a disabling marker.
133+isOrmoluDisable :: String -> Bool
134+isOrmoluDisable = magicComment "ORMOLU_DISABLE"
135+
136+-- | Construct a function for whitespace-insensitive matching of string.
137+magicComment ::
138+ -- | What to expect
139+ String ->
140+ -- | String to test
141+ String ->
142+ -- | Whether or not the two strings watch
143+ Bool
144+magicComment expected s0 = isJust $ do
145+ let trim = dropWhile isSpace
146+ s1 <- trim <$> L.stripPrefix "{-" (trim s0)
147+ s2 <- trim <$> L.stripPrefix expected s1
148+ s3 <- L.stripPrefix "-}" s2
149+ guard (all isSpace s3)
src/Ormolu/Utils.hs+74−15
@@ -1,44 +1,66 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ViewPatterns #-}
34
45-- | Random utilities used by the code.
56module Ormolu.Utils
6− ( combineSrcSpans',
7− isModule,
7+ ( RelativePos (..),
8+ attachRelativePos,
9+ combineSrcSpans',
810 notImplemented,
911 showOutputable,
1012 splitDocString,
1113 typeArgToType,
1214 unSrcSpan,
15+ incSpanLine,
1316 separatedByBlank,
17+ separatedByBlankNE,
18+ onTheSameLine,
19+ removeIndentation,
1420 )
1521where
1622
17−import Data.Data (Data, showConstr, toConstr)
23+import Data.Char (isSpace)
1824import Data.List (dropWhileEnd)
19−import qualified Data.List.NonEmpty as NE
2025import Data.List.NonEmpty (NonEmpty (..))
26+import qualified Data.List.NonEmpty as NE
2127import Data.Maybe (fromMaybe)
2228import Data.Text (Text)
2329import qualified Data.Text as T
2430import GHC
31+import GHC.DynFlags (baseDynFlags)
2532import qualified Outputable as GHC
2633
34+-- | Relative positions in a list.
35+data RelativePos
36+ = SinglePos
37+ | FirstPos
38+ | MiddlePos
39+ | LastPos
40+ deriving (Eq, Show)
41+
42+-- | Attach 'RelativePos'es to elements of a given list.
43+attachRelativePos :: [a] -> [(RelativePos, a)]
44+attachRelativePos = \case
45+ [] -> []
46+ [x] -> [(SinglePos, x)]
47+ (x : xs) -> (FirstPos, x) : markLast xs
48+ where
49+ markLast [] = []
50+ markLast [x] = [(LastPos, x)]
51+ markLast (x : xs) = (MiddlePos, x) : markLast xs
52+
2753-- | Combine all source spans from the given list.
2854combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
2955combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
3056
31−-- | Return 'True' if given element of AST is module.
32−isModule :: Data a => a -> Bool
33−isModule x = showConstr (toConstr x) == "HsModule"
34−
3557-- | Placeholder for things that are not yet implemented.
3658notImplemented :: String -> a
3759notImplemented msg = error $ "not implemented yet: " ++ msg
3860
3961-- | Pretty-print an 'GHC.Outputable' thing.
4062showOutputable :: GHC.Outputable o => o -> String
41−showOutputable = GHC.showSDocUnsafe . GHC.ppr
63+showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
4264
4365-- | Split and normalize a doc string. The result is a list of lines that
4466-- make up the comment.
@@ -77,20 +99,57 @@ splitDocString docStr =
7799 then dropSpace <$> xs
78100 else xs
79101
102+-- | Get 'LHsType' out of 'LHsTypeArg'.
80103typeArgToType :: LHsTypeArg p -> LHsType p
81104typeArgToType = \case
82105 HsValArg tm -> tm
83106 HsTypeArg _ ty -> ty
84107 HsArgPar _ -> notImplemented "HsArgPar"
85108
109+-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
86110unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
87−unSrcSpan (RealSrcSpan r) = Just r
88−unSrcSpan (UnhelpfulSpan _) = Nothing
111+unSrcSpan = \case
112+ RealSrcSpan r -> Just r
113+ UnhelpfulSpan _ -> Nothing
89114
90−-- | Do two declaration groups have a blank between them?
91−separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
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
92131separatedByBlank loc a b =
93132 fromMaybe False $ do
94− endA <- srcSpanEndLine <$> unSrcSpan (loc $ NE.last a)
95− startB <- srcSpanStartLine <$> unSrcSpan (loc $ NE.head b)
133+ endA <- srcSpanEndLine <$> unSrcSpan (loc a)
134+ startB <- srcSpanStartLine <$> unSrcSpan (loc b)
96135 pure (startB - endA >= 2)
136+
137+-- | Do two declaration groups have a blank between them?
138+separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
139+separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
140+
141+-- | Return 'True' if one span ends on the same line the second one starts.
142+onTheSameLine :: SrcSpan -> SrcSpan -> Bool
143+onTheSameLine a b =
144+ isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))
145+
146+-- | Remove indentation from a given 'String'. Return the input with
147+-- indentation removed and the detected indentation level.
148+removeIndentation :: String -> (String, Int)
149+removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)
150+ where
151+ n = minimum (getIndent <$> xs)
152+ getIndent y =
153+ if all isSpace y
154+ then 0
155+ else length (takeWhile isSpace y)
tests/Ormolu/PrinterSpec.hs+4−7
@@ -1,9 +1,6 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−module Ormolu.PrinterSpec
4− ( spec,
5− )
6−where
3+module Ormolu.PrinterSpec (spec) where
74
85import Control.Exception
96import Control.Monad
@@ -65,7 +62,7 @@ deriveOutput path =
6562-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
6663-- It also prints multi-line snippets in a more readable form.
6764shouldMatch :: Bool -> Text -> Text -> Expectation
68−shouldMatch idempotencyTest actual expected =
65+shouldMatch idempotenceTest actual expected =
6966 when (actual /= expected) . expectationFailure $
7067 unlines
7168 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
@@ -75,8 +72,8 @@ shouldMatch idempotencyTest actual expected =
7572 ]
7673 where
7774 pass =
78− if idempotencyTest
79− then "idempotency pass"
75+ if idempotenceTest
76+ then "idempotence pass"
8077 else "first pass"
8178
8279examplesDir :: Path Rel Dir