git.iko.soy/ormolu
on master help sign in
swap
dec158c119 ahead, 0 behind
320 files changed+4670−2172
since splitsnapshots
unifiedsplit
.buildkite/pipeline.yml+18 .circleci/config.yml−49 .github/workflows/binaries.yml+39 .github/workflows/build.sh+7 CHANGELOG.md+180 CONTRIBUTING.md+1−1 DESIGN.md+11−11 README.md+57−13 app/Main.hs+133−95 data/examples/declaration/annotation/annotation-out.hs+1 data/examples/declaration/class/associated-data1-out.hs−1 data/examples/declaration/class/associated-data2-out.hs−1 data/examples/declaration/class/associated-type-defaults-out.hs−2 data/examples/declaration/class/associated-types1-out.hs−1 data/examples/declaration/class/associated-types2-out.hs−1 data/examples/declaration/class/default-implementations-comments-out.hs−1 data/examples/declaration/class/default-signatures-out.hs−2 data/examples/declaration/class/default-signatures-simple-out.hs−2 data/examples/declaration/class/dependency-super-classes-out.hs+2−4 data/examples/declaration/class/functional-dependencies-out.hs+2−1 data/examples/declaration/class/multi-parameters2-out.hs+2−3 data/examples/declaration/class/newlines-after-where-out.hs+5 data/examples/declaration/class/newlines-after-where.hs+7 data/examples/declaration/class/newlines-and-default-decls-out.hs+11 data/examples/declaration/class/newlines-and-default-decls.hs+13 data/examples/declaration/class/newlines-and-haddocks-out.hs+23 data/examples/declaration/class/newlines-and-haddocks.hs+19 data/examples/declaration/class/newlines-between-methods-out.hs+17 data/examples/declaration/class/newlines-between-methods.hs+15 data/examples/declaration/class/single-parameters-out.hs−2 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/gadt/multiline-where-out.hs+7 data/examples/declaration/data/gadt/multiline-where.hs+6 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/associated-data-out.hs−2 data/examples/declaration/instance/associated-data.hs+1 data/examples/declaration/instance/associated-types-out.hs−1 data/examples/declaration/instance/associated-types.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/instance/instance-sigs-multiple-out.hs−2 data/examples/declaration/instance/multi-parameter-out.hs−2 data/examples/declaration/instance/newlines-after-where-out.hs+5 data/examples/declaration/instance/newlines-after-where.hs+7 data/examples/declaration/instance/newlines-between-methods-out.hs+18 data/examples/declaration/instance/newlines-between-methods.hs+16 data/examples/declaration/instance/single-parameter-out.hs−2 data/examples/declaration/signature/minimal/minimal-out.hs−2 data/examples/declaration/signature/specialize/specialize-instance-out.hs−4 data/examples/declaration/signature/standalone-kind-out.hs+13 data/examples/declaration/signature/standalone-kind.hs+13 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-families/closed-type-family/multi-line-out.hs+6−5 data/examples/declaration/type-synonyms/with-weird-haddock-out.hs+3 data/examples/declaration/type-synonyms/with-weird-haddock.hs+1 data/examples/declaration/type/visible-forall-out.hs+2 data/examples/declaration/type/visible-forall.hs+2 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/expression-applications-out.hs−9 data/examples/declaration/value/function/arrow/expression-applications.hs−9 data/examples/declaration/value/function/arrow/expression-forms-out.hs−14 data/examples/declaration/value/function/arrow/expression-forms.hs−11 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+10−6 data/examples/declaration/value/function/arrow/proc-forms2.hs+6−6 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+10−4 data/examples/declaration/value/function/multi-way-if.hs+5 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/overindentation-out.hs+11−9 data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs+8−8 data/examples/declaration/value/function/pattern/multiline-case-pattern-out.hs+2−2 data/examples/declaration/value/function/pattern/view-pattern-out.hs−3 data/examples/declaration/value/function/pattern/view-pattern.hs−3 data/examples/declaration/value/function/record-constructors-out.hs−27 data/examples/declaration/value/function/record/constructors-out.hs+31 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+15 data/examples/declaration/value/function/record/dot.hs+14 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+13 data/examples/declaration/value/function/record/inter-comments.hs+11 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+7−6 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/declaration/value/function/type-applications-out.hs+6 data/examples/declaration/value/function/type-applications.hs+5 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+5 data/examples/import/qualified-post.hs+5 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-alignment-out.hs−1 data/examples/other/comment-before-hanging-out.hs+5 data/examples/other/comment-before-hanging.hs+5 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−51 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−3 nix/nixpkgs/default.nix+7−3 nix/ormolize/default.nix+29−13 nix/ormolize/ormolize.sh−17 ormolu.cabal+174−157 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+2−13 src/GHC/DynFlags.hs+33−20 src/Ormolu.hs+10−7 src/Ormolu/Config.hs+67−27 src/Ormolu/Diff.hs+23−13 src/Ormolu/Exception.hs+4−11 src/Ormolu/Imports.hs+168−51 src/Ormolu/Parser.hs+84−84 src/Ormolu/Parser/CommentStream.hs+147−61 src/Ormolu/Parser/Pragma.hs+4−4 src/Ormolu/Parser/Result.hs+26−13 src/Ormolu/Parser/Shebang.hs+27 src/Ormolu/Printer.hs+17−5 src/Ormolu/Printer/Combinators.hs+39−53 src/Ormolu/Printer/Comments.hs+62−76 src/Ormolu/Printer/Internal.hs+173−108 src/Ormolu/Printer/Meat/Common.hs+13−11 src/Ormolu/Printer/Meat/Declaration.hs+174−109 src/Ormolu/Printer/Meat/Declaration.hs-boot+2−3 src/Ormolu/Printer/Meat/Declaration/Annotation.hs+2−3 src/Ormolu/Printer/Meat/Declaration/Class.hs+22−33 src/Ormolu/Printer/Meat/Declaration/Data.hs+68−43 src/Ormolu/Printer/Meat/Declaration/Default.hs+4−5 src/Ormolu/Printer/Meat/Declaration/Foreign.hs+2−3 src/Ormolu/Printer/Meat/Declaration/Instance.hs+13−20 src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+2−5 src/Ormolu/Printer/Meat/Declaration/Rule.hs+12−13 src/Ormolu/Printer/Meat/Declaration/Signature.hs+49−33 src/Ormolu/Printer/Meat/Declaration/Splice.hs+2−3 src/Ormolu/Printer/Meat/Declaration/Type.hs+6−7 src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+22−23 src/Ormolu/Printer/Meat/Declaration/Value.hs+404−344 src/Ormolu/Printer/Meat/Declaration/Value.hs-boot−4 src/Ormolu/Printer/Meat/Declaration/Warning.hs+9−13 src/Ormolu/Printer/Meat/ImportExport.hs+44−35 src/Ormolu/Printer/Meat/Module.hs+26−20 src/Ormolu/Printer/Meat/Pragma.hs+22−12 src/Ormolu/Printer/Meat/Type.hs+85−61 src/Ormolu/Printer/Operators.hs+51−68 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+83−9 tests/Ormolu/PrinterSpec.hs+7−10
.buildkite/pipeline.ymlnew file+18
@@ -0,0 +1,18 @@
1+steps:
2+ - label: Build and test with GHC 8.6.5
3+ command: |
4+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc865
5+ timeout: 100
6+ - label: Build and test with GHC 8.8.4
7+ command: |
8+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc884
9+ timeout: 100
10+ - label: Build and test with GHC 8.10.1
11+ command: |
12+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc8101
13+ timeout: 100
14+ - wait
15+ - label: Check formatting
16+ command: |
17+ ./format.sh
18+ git diff --exit-code --color=always
.circleci/config.ymldeleted−49
@@ -1,49 +0,0 @@
1−version: 2
2−
3−jobs:
4− build:
5− docker:
6− - image: nixos/nix:2.1.3
7− steps:
8− - checkout
9− - run:
10− name: Add ca-certificates
11− command: |
12− apk --no-progress update
13− apk --no-progress add ca-certificates
14− - run:
15− name: Setup Cachix
16− command: |
17− nix-env -iA cachix -f https://cachix.org/api/v1/install
18− USER=dummy cachix use tweag
19− - run:
20− name: Build environment
21− command: |
22− nix-shell --pure --run :
23− - run:
24− name: Push Cachix
25− command: |
26− if [ -n "$CACHIX_SIGNING_KEY" ];
27− then nix-store -qR --include-outputs $(nix-instantiate default.nix) | cachix push tweag;
28− fi
29− - run:
30− name: Build the package (includes running the tests)
31− command: nix-build --keep-going
32− - run:
33− name: Check formatting
34− command: |
35− ./format.sh
36− nix-shell -p "(import ./nix/nixpkgs/default.nix).git" --command "git diff --exit-code --color=always"
37− - run:
38− name: Generate Haddocks
39− command: nix-build --attr ormolu.doc
40− - store_artifacts:
41− path: result-doc/share/doc
42− destination: haddock
43−
44−workflows:
45− version: 2
46− build:
47− jobs:
48− - build:
49− context: org-global
.github/workflows/binaries.ymlnew file+39
@@ -0,0 +1,39 @@
1+name: Build binaries
2+on:
3+ release:
4+ types: [published]
5+jobs:
6+ build:
7+ strategy:
8+ fail-fast: false
9+ matrix:
10+ os: [ubuntu-latest, macOS-latest, windows-latest]
11+ runs-on: ${{ matrix.os }}
12+ steps:
13+ - uses: actions/checkout@v2
14+ - uses: actions/setup-haskell@v1
15+ if: runner.os != 'Linux'
16+ with:
17+ ghc-version: '8.10.1'
18+ cabal-version: '3.2'
19+ - name: Build Linux binary
20+ if: runner.os == 'Linux'
21+ run: |
22+ docker run \
23+ -v $(pwd):/mnt -w /mnt \
24+ utdemir/ghc-musl:v14-ghc8101 \
25+ bash .github/workflows/build.sh
26+ - name: Build ${{ runner.os }} binary
27+ if: runner.os != 'Linux'
28+ shell: bash
29+ run: |
30+ cabal build exe:ormolu
31+ cp $(find dist-newstyle \( -name ormolu -o -name ormolu.exe \) -type f) ormolu
32+ - uses: actions/upload-release-asset@v1
33+ env:
34+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
35+ with:
36+ upload_url: ${{ github.event.release.upload_url }}
37+ asset_path: ormolu
38+ asset_name: ormolu-${{ runner.os }}
39+ asset_content_type: application/octet-stream
.github/workflows/build.shnew file+7
@@ -0,0 +1,7 @@
1+set -e
2+
3+cabal update
4+cabal build exe:ormolu --enable-executable-static --ghc-options="-split-sections"
5+
6+cp $(find dist-newstyle -name ormolu -type f) .
7+strip -s ormolu
CHANGELOG.md+180
@@ -1,8 +1,188 @@
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+
124+* When given several files to format, Ormolu does not stop on the first
125+ failure, but tries to format all the files. [Issue
126+ 502](https://github.com/tweag/ormolu/issues/502).
127+
128+* Made rendering of pattern matches involving operators consistent with
129+ other cases of rendering of operators. [Issue
130+ 500](https://github.com/tweag/ormolu/issues/500).
131+
132+* More compact rendering of type family injectivity constraints. [Issue
133+ 482](https://github.com/tweag/ormolu/issues/482).
134+
135+* Improved rendering of the keyword `where` in class, data, and type family
136+ declarations. When headers of these declarations are multi-line `where` is
137+ now put on its own line. [Issue
138+ 509](https://github.com/tweag/ormolu/issues/509).
139+
140+* Fixed the bug pertaining to rendering of arrow notation with multiline
141+ expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513).
142+
143+* Made rendering of data type definitions, value-level applications, and
144+ application of types use the same style. Moreover, existential now doesn't
145+ cause the data constructor be unconditionally rendered in multiline
146+ layout. [Issue 427](https://github.com/tweag/ormolu/issues/427).
147+
148+* Records with a single data constructor are now formatted more compactly.
149+ [Issue 425](https://github.com/tweag/ormolu/issues/425).
150+
151+* Switched to `ghc-lib-parser-8.10.1`.
152+
153+* Implemented support for the new language extensions `ImportQualifiedPost`
154+ and `StandaloneKindSignatures`.
155+
156+## Ormolu 0.0.3.1
157+
158+* Fixed rendering of record updates with the record dot preprocessor syntax
159+ [Issue 498](https://github.com/tweag/ormolu/issues/498).
160+
161+## Ormolu 0.0.3.0
162+
3163* Fixed an issue related to unnecessary use of curly braces. [Issue
4164 473](https://github.com/tweag/ormolu/issues/473).
5165
166+* Fixed the issue with formatting multi-way if when it happens to be a
167+ function applied to arguments [Issue
168+ 488](https://github.com/tweag/ormolu/issues/488). This changed the way
169+ multi-line if is formatted in general.
170+
171+* Added support for record dot pre-processor when used via the plugin.
172+ [Issue 486](https://github.com/tweag/ormolu/issues/486).
173+
174+* Stopped hanging record constructors and improved placing
175+ potentially-hanging consturctions in the presence of comments. [Issue
176+ 447](https://github.com/tweag/ormolu/issues/447).
177+
178+* Fixed indentation in presence of type applications. [Issue
179+ 493](https://github.com/tweag/ormolu/issues/493).
180+
181+* Class and instance declarations now do not have a blank line after
182+ `where`. Grouping of methods from the original input is also preserved
183+ with some normalizations. [Issue
184+ 431](https://github.com/tweag/ormolu/issues/431).
185+
6186## Ormolu 0.0.2.0
7187
8188* Switched to `ghc-lib-parser` instead of depending on the `ghc` package
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+57−13
@@ -4,7 +4,7 @@
44[![Hackage](https://img.shields.io/hackage/v/ormolu.svg?style=flat)](https://hackage.haskell.org/package/ormolu)
55[![Stackage Nightly](http://stackage.org/package/ormolu/badge/nightly)](http://stackage.org/nightly/package/ormolu)
66[![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/ormolu)
7−[![CircleCI](https://circleci.com/gh/tweag/ormolu/tree/master.svg?style=svg&circle-token=cfd37a39265561eb44e608f97cf953cb2a394c03)](https://circleci.com/gh/tweag/ormolu/tree/master)
7+[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu)
88
99Ormolu is a formatter for Haskell source code. The project was created with
1010the following goals in mind:
@@ -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,20 +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−
108133## Running on Hackage
109134
110135It's possible to try Ormolu on arbitrary packages from Hackage. For that
@@ -119,6 +144,22 @@ also contain formatted `.hs` files for inspection and original inputs with
119144`.hs-original` extension (those are with CPP dropped, exactly what is fed
120145into Ormolu).
121146
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+
122163## Contributing
123164
124165See [CONTRIBUTING.md][contributing].
@@ -129,9 +170,12 @@ See [LICENSE.md][license].
129170
130171Copyright © 2018–present Tweag I/O
131172
132−[design]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
173+[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
133174[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md
134175[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md
135176[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
136177[emacs-package]: https://github.com/vyorkin/ormolu.el
137178[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode
179+[vim-ormolu]: https://github.com/sdiehl/vim-ormolu
180+[neoformat]: https://github.com/sbdchd/neoformat
181+[aur]: https://aur.archlinux.org/packages/ormolu
app/Main.hs+133−95
@@ -1,12 +1,17 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeApplications #-}
56
67module Main (main) where
78
9+import Control.Exception (SomeException, displayException, try)
810import Control.Monad
11+import Data.Bool (bool)
12+import Data.Either (lefts)
913import Data.List (intercalate, sort)
14+import qualified Data.Text.IO as TIO
1015import Data.Version (showVersion)
1116import Development.GitRev
1217import Options.Applicative
@@ -16,10 +21,8 @@ import Ormolu.Utils (showOutputable)
1621import Paths_ormolu (version)
1722import System.Exit (ExitCode (..), exitWith)
1823import System.IO (hPutStrLn, stderr)
19−import qualified Data.Text.IO as TIO
2024
2125-- | Entry point of the program.
22−
2326main :: IO ()
2427main = withPrettyOrmoluExceptions $ do
2528 Opts {..} <- execParser optsParserInfo
@@ -27,35 +30,50 @@ main = withPrettyOrmoluExceptions $ do
2730 case optInputFiles of
2831 [] -> formatOne' Nothing
2932 ["-"] -> formatOne' Nothing
30− xs -> mapM_ (formatOne' . Just) xs
33+ [x] -> formatOne' (Just x)
34+ xs -> do
35+ -- It is possible to get IOException, error's and 'OrmoluException's
36+ -- from 'formatOne', so we just catch everything.
37+ errs <-
38+ lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)
39+ unless (null errs) $ do
40+ mapM_ (hPutStrLn stderr . displayException) errs
41+ exitWith (ExitFailure 102)
3142
3243-- | Format a single input.
33−
34−formatOne
35− :: Mode -- ^ Mode of operation
36− -> Config -- ^ Configuration
37− -> Maybe FilePath -- ^ File to format or stdin as 'Nothing'
38− -> IO ()
44+formatOne ::
45+ -- | Mode of operation
46+ Mode ->
47+ -- | Configuration
48+ Config RegionIndices ->
49+ -- | File to format or stdin as 'Nothing'
50+ Maybe FilePath ->
51+ IO ()
3952formatOne mode config = \case
4053 Nothing -> do
4154 r <- ormoluStdin config
4255 case mode of
4356 Stdout -> TIO.putStr r
44− _ -> do
45− hPutStrLn stderr
57+ _ -> do
58+ hPutStrLn
59+ stderr
4660 "This feature is not supported when input comes from stdin."
47− -- 101 is different from all the other exit codes we already use.
61+ -- 101 is different from all the other exit codes we already use.
4862 exitWith (ExitFailure 101)
4963 Just inputFile -> do
50− r <- ormoluFile config inputFile
64+ originalInput <- TIO.readFile inputFile
65+ formattedInput <- ormoluFile config inputFile
5166 case mode of
5267 Stdout ->
53− TIO.putStr r
54− InPlace ->
55− 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
5675 Check -> do
57− r' <- TIO.readFile inputFile
58− when (r /= r') $
76+ when (formattedInput /= originalInput) $
5977 -- 100 is different to all the other exit code that are emitted
6078 -- either from an 'OrmoluException' or from 'error' and
6179 -- 'notImplemented'.
@@ -65,101 +83,121 @@ formatOne mode config = \case
6583-- Command line options parsing.
6684
6785data Opts = Opts
68− { optMode :: !Mode
69− -- ^ Mode of operation
70− , optConfig :: !Config
71− -- ^ Ormolu 'Config'
72− , optInputFiles :: ![FilePath]
73− -- ^ Haskell source files to format or stdin (when the list is empty)
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]
7492 }
7593
7694-- | Mode of operation.
77−
7895data Mode
79− = Stdout -- ^ Output formatted source code to stdout
80− | InPlace -- ^ Overwrite original file
81− | Check -- ^ Exit with non-zero status code if
82− -- source is not already formatted
96+ = -- | Output formatted source code to stdout
97+ Stdout
98+ | -- | Overwrite original file
99+ InPlace
100+ | -- | Exit with non-zero status code if
101+ -- source is not already formatted
102+ Check
83103 deriving (Eq, Show)
84104
85105optsParserInfo :: ParserInfo Opts
86−optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $
87− [ fullDesc
88− , progDesc ""
89− , header ""
90− ]
106+optsParserInfo =
107+ info (helper <*> ver <*> exts <*> optsParser) . mconcat $
108+ [ fullDesc,
109+ progDesc "",
110+ header ""
111+ ]
91112 where
92113 ver :: Parser (a -> a)
93− ver = infoOption verStr . mconcat $
94− [ long "version"
95− , short 'v'
96− , help "Print version of the program"
97− ]
98− verStr = intercalate "\n"
99− [ unwords
100− [ "ormolu"
101− , showVersion version
102− , $gitBranch
103− , $gitHash
114+ ver =
115+ infoOption verStr . mconcat $
116+ [ long "version",
117+ short 'v',
118+ help "Print version of the program"
119+ ]
120+ verStr =
121+ intercalate
122+ "\n"
123+ [ unwords
124+ [ "ormolu",
125+ showVersion version,
126+ $gitBranch,
127+ $gitHash
128+ ],
129+ "using ghc-lib-parser " ++ VERSION_ghc_lib_parser
104130 ]
105− , "using ghc-lib-parser " ++ VERSION_ghc_lib_parser
106− ]
107131 exts :: Parser (a -> a)
108− exts = infoOption displayExts . mconcat $
109− [ long "manual-exts"
110− , help "Display extensions that need to be enabled manually"
111− ]
132+ exts =
133+ infoOption displayExts . mconcat $
134+ [ long "manual-exts",
135+ help "Display extensions that need to be enabled manually"
136+ ]
112137 displayExts = unlines $ sort (showOutputable <$> manualExts)
113138
114139optsParser :: Parser Opts
115−optsParser = Opts
116− <$> (option parseMode . mconcat)
117− [ long "mode"
118− , short 'm'
119− , metavar "MODE"
120− , value Stdout
121− , help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"
122− ]
123− <*> configParser
124− <*> (many . strArgument . mconcat)
125− [ metavar "FILE"
126− , help "Haskell source files to format or stdin (default)"
127− ]
140+optsParser =
141+ Opts
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+ )
154+ <*> configParser
155+ <*> (many . strArgument . mconcat)
156+ [ metavar "FILE",
157+ help "Haskell source files to format or stdin (default)"
158+ ]
128159
129−configParser :: Parser Config
130−configParser = Config
131− <$> (fmap (fmap DynOption) . many . strOption . mconcat)
132− [ long "ghc-opt"
133− , short 'o'
134− , metavar "OPT"
135− , help "GHC options to enable (e.g. language extensions)"
136− ]
137− <*> (switch . mconcat)
138− [ long "unsafe"
139− , short 'u'
140− , help "Do formatting faster but without automatic detection of defects"
141− ]
142− <*> (switch . mconcat)
143− [ long "debug"
144− , short 'd'
145− , help "Output information useful for debugging"
146− ]
147− <*> (switch . mconcat)
148− [ long "tolerate-cpp"
149− , short 'p'
150− , help "Do not fail if CPP pragma is present"
151− ]
152− <*> (switch . mconcat)
153− [ long "check-idempotency"
154− , short 'c'
155− , help "Fail if formatting is not idempotent"
156− ]
160+configParser :: Parser (Config RegionIndices)
161+configParser =
162+ Config
163+ <$> (fmap (fmap DynOption) . many . strOption . mconcat)
164+ [ long "ghc-opt",
165+ short 'o',
166+ metavar "OPT",
167+ help "GHC options to enable (e.g. language extensions)"
168+ ]
169+ <*> (switch . mconcat)
170+ [ long "unsafe",
171+ short 'u',
172+ help "Do formatting faster but without automatic detection of defects"
173+ ]
174+ <*> (switch . mconcat)
175+ [ long "debug",
176+ short 'd',
177+ help "Output information useful for debugging"
178+ ]
179+ <*> (switch . mconcat)
180+ [ long "check-idempotence",
181+ short 'c',
182+ help "Fail if formatting is not idempotent"
183+ ]
184+ <*> ( RegionIndices
185+ <$> (optional . option auto . mconcat)
186+ [ long "start-line",
187+ metavar "START",
188+ help "Start line of the region to format (starts from 1)"
189+ ]
190+ <*> (optional . option auto . mconcat)
191+ [ long "end-line",
192+ metavar "END",
193+ help "End line of the region to format (inclusive)"
194+ ]
195+ )
157196
158197----------------------------------------------------------------------------
159198-- Helpers
160199
161200-- | Parse 'Mode'.
162−
163201parseMode :: ReadM Mode
164202parseMode = eitherReader $ \case
165203 "stdout" -> Right Stdout
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/class/associated-data1-out.hs−1
@@ -4,7 +4,6 @@ class Foo a where data FooBar a
44
55-- | Something.
66class Bar a where
7−
87 -- | Bar bar
98 data BarBar a
109
data/examples/declaration/class/associated-data2-out.hs−1
@@ -4,7 +4,6 @@ module Main where
44
55-- | Something more.
66class Baz a where
7−
87 -- | Baz bar
98 data
109 BazBar
data/examples/declaration/class/associated-type-defaults-out.hs−2
@@ -4,7 +4,6 @@ class Foo a where type FooBar a = Int
44
55-- | Something.
66class Bar a where
7−
87 -- Define bar
98 type
109 BarBar a =
@@ -18,7 +17,6 @@ class Bar a where
1817 a
1918
2019class Baz a where
21−
2220 type
2321 BazBar
2422 a
data/examples/declaration/class/associated-types1-out.hs−1
@@ -4,7 +4,6 @@ class Foo a where type FooBar a
44
55-- | Something.
66class Bar a where
7−
87 -- | Bar bar
98 type BarBar a
109
data/examples/declaration/class/associated-types2-out.hs−1
@@ -4,7 +4,6 @@ module Main where
44
55-- | Something more.
66class Baz a where
7−
87 -- | Baz bar
98 type
109 BazBar
data/examples/declaration/class/default-implementations-comments-out.hs−1
@@ -2,7 +2,6 @@ module Main where
22
33-- | Baz
44class Baz a where
5−
65 foobar :: a -> a
76 foobar a =
87 barbaz (bazbar a)
data/examples/declaration/class/default-signatures-out.hs−2
@@ -4,13 +4,11 @@ module Main where
44
55-- | Something else.
66class Bar a where
7−
87 -- | Bar
98 bar ::
109 String ->
1110 String ->
1211 a
13−
1412 -- Pointless comment
1513 default bar ::
1614 ( Read a,
data/examples/declaration/class/default-signatures-simple-out.hs−2
@@ -2,9 +2,7 @@ module Main where
22
33-- | Something.
44class Foo a where
5−
65 -- | Foo
76 foo :: a -> String
8−
97 default foo :: Show a => a -> String
108 foo = show
data/examples/declaration/class/dependency-super-classes-out.hs+2−4
@@ -4,9 +4,7 @@ module Main where
44
55-- | Something.
66class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where
7−
87 get :: m s
9−
108 put :: s -> m ()
119
1210-- | 'MonadParsec'
@@ -15,8 +13,8 @@ class
1513 MonadPlus m -- Potential for failure
1614 ) =>
1715 MonadParsec e s m
18− | m -> e s where
19−
16+ | m -> e s
17+ where
2018 -- | 'getState' returns state
2119 getState ::
2220 m s
data/examples/declaration/class/functional-dependencies-out.hs+2−1
@@ -14,5 +14,6 @@ class
1414 b c -> a d, -- Bar
1515 a c -> b d, -- Baz
1616 a c d -> b,
17− a b d -> a b c d where
17+ a b d -> a b c d
18+ where
1819 baz :: a -> b
data/examples/declaration/class/multi-parameters2-out.hs+2−3
@@ -10,11 +10,10 @@ class
1010 c -- Baz bar
1111 d -- Baz baz
1212 e -- Rest
13− f where
14−
13+ f
14+ where
1515 barbaz ::
1616 a -> f
17−
1817 bazbar ::
1918 e ->
2019 f
data/examples/declaration/class/newlines-after-where-out.hsnew file+5
@@ -0,0 +1,5 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+
4+class Num a where
5+ (+) :: a -> a -> a
data/examples/declaration/class/newlines-after-where.hsnew file+7
@@ -0,0 +1,7 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+
4+class Num a where
5+
6+
7+ (+) :: a -> a -> a
data/examples/declaration/class/newlines-and-default-decls-out.hsnew file+11
@@ -0,0 +1,11 @@
1+class Foo a where
2+ foo :: a
3+ default foo :: ()
4+ foo = ()
5+ bar :: a
6+ default bar :: ()
7+ bar = ()
8+
9+ qux :: a
10+ default qux :: ()
11+ qux = ()
data/examples/declaration/class/newlines-and-default-decls.hsnew file+13
@@ -0,0 +1,13 @@
1+class Foo a where
2+ foo :: a
3+ default foo :: ()
4+ foo = ()
5+ bar :: a
6+ default bar :: ()
7+ bar = ()
8+
9+ qux :: a
10+
11+ default qux :: ()
12+
13+ qux = ()
data/examples/declaration/class/newlines-and-haddocks-out.hsnew file+23
@@ -0,0 +1,23 @@
1+class Foo a where
2+ -- | Haddock
3+ foo :: a
4+
5+ -- | Another Haddock
6+ bar :: a
7+
8+ baz :: a
9+ -- ^ Post-Haddock
10+
11+ raz :: a
12+ -- ^ Another Post-Haddock
13+
14+ -- | One more Haddock
15+ qux :: a
16+
17+ -- Comment before a Haddock
18+
19+ -- | And one more Haddock
20+ xyz :: a
21+
22+ -- | Haddock followed by a blank line
23+ abc :: a
data/examples/declaration/class/newlines-and-haddocks.hsnew file+19
@@ -0,0 +1,19 @@
1+class Foo a where
2+ -- | Haddock
3+ foo :: a
4+ -- | Another Haddock
5+ bar :: a
6+ baz :: a
7+ -- ^ Post-Haddock
8+ raz :: a
9+ -- ^ Another Post-Haddock
10+
11+ -- | One more Haddock
12+ qux :: a
13+ -- Comment before a Haddock
14+ -- | And one more Haddock
15+ xyz :: a
16+
17+ -- | Haddock followed by a blank line
18+
19+ abc :: a
data/examples/declaration/class/newlines-between-methods-out.hsnew file+17
@@ -0,0 +1,17 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+ (-) :: a -> a -> a
4+ (*) :: a -> a -> a
5+
6+ -- Comment before definition
7+ negate :: a -> a
8+
9+ -- Comment after definition
10+
11+ -- Separator
12+
13+ abs :: a -> a
14+ signum :: a -> a
15+
16+ -- Comment between unrelated definitions
17+ fromInteger :: Integer -> a
data/examples/declaration/class/newlines-between-methods.hsnew file+15
@@ -0,0 +1,15 @@
1+class Num a where
2+ (+) :: a -> a -> a
3+ (-) :: a -> a -> a
4+ (*) :: a -> a -> a
5+
6+ -- Comment before definition
7+ negate :: a -> a
8+ -- Comment after definition
9+
10+ -- Separator
11+
12+ abs :: a -> a
13+ signum :: a -> a
14+ -- Comment between unrelated definitions
15+ fromInteger :: Integer -> a
data/examples/declaration/class/single-parameters-out.hs−2
@@ -21,8 +21,6 @@ class Baz a where
2121 a
2222
2323class BarBaz a where
24−
2524 barbaz ::
2625 a -> b
27−
2826 bazbar :: b -> a
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/gadt/multiline-where-out.hsnew file+7
@@ -0,0 +1,7 @@
1+data
2+ Foo
3+ a
4+ b
5+ c
6+ where
7+ Foo :: a -> b -> c -> Foo a b c
data/examples/declaration/data/gadt/multiline-where.hsnew file+6
@@ -0,0 +1,6 @@
1+data
2+ Foo
3+ a
4+ b
5+ c where
6+ Foo :: a -> b -> c -> Foo a b c
data/examples/declaration/data/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/associated-data-out.hs−2
@@ -11,9 +11,7 @@ instance Foo Double where
1111 Double
1212
1313instance Foo [a] where
14−
1514 data Bar [a]
1615 = ListBar [Bar a]
17−
1816 data Baz [a]
1917 = ListBaz
data/examples/declaration/instance/associated-data.hs+1
@@ -13,6 +13,7 @@ instance Foo Double where
1313
1414instance Foo [a]
1515 where
16+
1617 data Bar [a] =
1718 ListBar [Bar a]
1819 data Baz [a] =
data/examples/declaration/instance/associated-types-out.hs−1
@@ -3,7 +3,6 @@
33instance Foo Int where type Bar Int = Double
44
55instance Foo Double where
6−
76 type
87 Bar
98 Double =
data/examples/declaration/instance/associated-types.hs+2
@@ -9,5 +9,7 @@ instance Foo Double
99 Double
1010 =
1111 [Double]
12+
13+
1214 type instance Baz Double
1315 = [Double]
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/instance/instance-sigs-multiple-out.hs−2
@@ -1,12 +1,10 @@
11{-# LANGUAGE InstanceSigs #-}
22
33instance Applicative [] where
4−
54 pure ::
65 a ->
76 [a]
87 pure a = [a]
9−
108 (<*>) ::
119 [a] -> [a] -> [a]
1210 (<*>) _ _ = []
data/examples/declaration/instance/multi-parameter-out.hs−2
@@ -1,7 +1,5 @@
11instance MonadReader a ((->) a) where ask = id
22
33instance MonadState s (State s) where
4−
54 get = State.get
6−
75 put = State.put
data/examples/declaration/instance/newlines-after-where-out.hsnew file+5
@@ -0,0 +1,5 @@
1+instance Num X where
2+ (+) = undefined
3+
4+instance Num Y where
5+ (+) = undefined
data/examples/declaration/instance/newlines-after-where.hsnew file+7
@@ -0,0 +1,7 @@
1+instance Num X where
2+ (+) = undefined
3+
4+instance Num Y where
5+
6+
7+ (+) = undefined
data/examples/declaration/instance/newlines-between-methods-out.hsnew file+18
@@ -0,0 +1,18 @@
1+instance Num a => Num (Diff a) where
2+ D u dudx + D v dvdx = D (u + v) (dudx + dvdx)
3+ D u dudx - D v dvdx = D (u - v) (dudx - dvdx)
4+ D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx)
5+
6+ -- Comment before definition
7+ negate (D u dudx) = D (- u) (- dudx)
8+ negate (Z u dudx) = undefined
9+
10+ -- Comment after definition
11+
12+ -- Separator
13+
14+ abs (D u _) = D (abs u) (signum u)
15+ signum (D u _) = D (signum u) 0
16+
17+ -- Comment between unrelated definitions
18+ fromInteger n = D (fromInteger n) 0
data/examples/declaration/instance/newlines-between-methods.hsnew file+16
@@ -0,0 +1,16 @@
1+instance Num a => Num (Diff a) where
2+ D u dudx + D v dvdx = D (u + v) (dudx + dvdx)
3+ D u dudx - D v dvdx = D (u - v) (dudx - dvdx)
4+ D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx)
5+
6+ -- Comment before definition
7+ negate (D u dudx) = D (-u) (-dudx)
8+ negate (Z u dudx) = undefined
9+ -- Comment after definition
10+
11+ -- Separator
12+
13+ abs (D u _) = D (abs u) (signum u)
14+ signum (D u _) = D (signum u) 0
15+ -- Comment between unrelated definitions
16+ fromInteger n = D (fromInteger n) 0
data/examples/declaration/instance/single-parameter-out.hs−2
@@ -1,9 +1,7 @@
11instance Monoid Int where (<>) x y = x + y
22
33instance Enum Int where
4−
54 fromEnum x = x
6−
75 toEnum =
86 \x ->
97 x
data/examples/declaration/signature/minimal/minimal-out.hs−2
@@ -1,5 +1,4 @@
11class Foo a where
2−
32 {-# MINIMAL (==) | ((/=), foo) #-}
43
54 {-# MINIMAL
@@ -12,5 +11,4 @@ class Foo a where
1211 #-}
1312
1413 (==) :: a -> a -> Bool
15−
1614 (/=) :: a -> a -> Bool
data/examples/declaration/signature/specialize/specialize-instance-out.hs−4
@@ -3,16 +3,12 @@ data Foo a = Foo a
33data VT v m r = VT v m r
44
55instance (Eq a) => Eq (Foo a) where
6−
76 {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}
8−
97 (==) (Foo a) (Foo b) = (==) a b
108
119instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where
12−
1310 {-# SPECIALIZE instance
1411 ( Factored m Int => Num (VT U.Vector m Int)
1512 )
1613 #-}
17−
1814 VT x + VT y = VT $ V.zipWith (+) x y
data/examples/declaration/signature/standalone-kind-out.hsnew file+13
@@ -0,0 +1,13 @@
1+{-# LANGUAGE StandaloneKindSignatures #-}
2+
3+type T ::
4+ (k -> Type) ->
5+ k ->
6+ Type
7+data T m a = MkT (m a) (T Maybe (m a))
8+
9+type C1 :: Type -> Constraint
10+class C1 a
11+
12+type F :: Type -> Type
13+type family F
data/examples/declaration/signature/standalone-kind.hsnew file+13
@@ -0,0 +1,13 @@
1+{-# LANGUAGE StandaloneKindSignatures #-}
2+
3+type T :: (k -> Type)
4+ -> k
5+ -> Type
6+
7+data T m a = MkT (m a) (T Maybe (m a))
8+
9+type C1 :: Type -> Constraint
10+class C1 a
11+
12+type F :: Type -> Type
13+type family F
data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs−1
@@ -1,3 +1,2 @@
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-families/closed-type-family/multi-line-out.hs+6−5
@@ -1,7 +1,7 @@
11type family
22 Id a =
3− result
4− | result -> a where
3+ result | result -> a
4+ where
55 Id a =
66 a
77
@@ -10,14 +10,15 @@ type family
1010 (a :: k)
1111 b
1212 c =
13− foo
14− | foo -> k b where
13+ foo | foo -> k b
14+ where
1515 G a b c =
1616 (a, b)
1717
1818type family
1919 F a ::
20− * -> * where
20+ * -> *
21+ where
2122 F Int = Double
2223 F Bool =
2324 Char
data/examples/declaration/type-synonyms/with-weird-haddock-out.hsnew file+3
@@ -0,0 +1,3 @@
1+type Elims =
2+ -- | eliminations ordered left-to-right.
3+ [Elim]
data/examples/declaration/type-synonyms/with-weird-haddock.hsnew file+1
@@ -0,0 +1 @@
1+type Elims = [Elim] -- ^ eliminations ordered left-to-right.
data/examples/declaration/type/visible-forall-out.hsnew file+2
@@ -0,0 +1,2 @@
1+-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
2+data T :: forall k -> k -> Type
data/examples/declaration/type/visible-forall.hsnew file+2
@@ -0,0 +1,2 @@
1+-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
2+data T :: forall k -> k -> Type
data/examples/declaration/value/function/arg-breakpoints-out.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arg-breakpoints.hsnew file+3
@@ -0,0 +1,3 @@
1+foo
2+ bar =
3+ body
data/examples/declaration/value/function/arrow/expression-applications-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−foo x y = x -< y
4−
5−bar f x =
6− f x -< -- Hello
7− x -- World
8−
9−baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-applications.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−foo x y = x -< y
4−
5−bar f x
6− = f x -- Hello
7− -< x -- World
8−
9−baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-forms-out.hsdeleted−14
@@ -1,14 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−foo f g x y = (| test (f -< x) (g -< y) |)
4−
5−bar f g x y =
6− (|
7− test
8− ( f -<
9− x
10− )
11− ( g -<
12− y
13− )
14− |)
data/examples/declaration/value/function/arrow/expression-forms.hsdeleted−11
@@ -1,11 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−foo f g x y = (| test (f -< x) (g -< y) |)
4−
5−bar f g x y = (|
6− test
7− (f
8− -< x)
9− (g
10− -< y)
11− |)
data/examples/declaration/value/function/arrow/multiline-case-out.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x <-
5+ case x of X -> x
6+ -<
7+ y
8+ a -< b
data/examples/declaration/value/function/arrow/multiline-case.hsnew file+7
@@ -0,0 +1,7 @@
1+{-# LANGUAGE Arrows #-}
2+
3+f = proc x -> do
4+ x
5+ <- case x of X -> x
6+ -< y
7+ a -< b
data/examples/declaration/value/function/arrow/proc-applications-out.hs+6−5
@@ -9,10 +9,11 @@ bar f x =
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+10−6
@@ -4,15 +4,19 @@ bar0 f g h x =
44 proc (y, z) ->
55 (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)
66
7−bar1 f g x y = proc _ -> f -< x &&& g -< y
7+bar1 f g x y = proc _ -> (f -< x) &&& (g -< y)
88
99bar2 f g h x =
1010 proc (y, z) ->
11− h f . (h g) -< (y x) . y z ||| (h g) . h f -< y z . (y x)
11+ (h f . (h g) -< (y x) . y z) ||| ((h g) . h f -< y z . (y x))
1212
1313bar3 f g h x =
1414 proc (y, z) ->
15− (h f . h g) -<
16− (y x) . y z
17− ||| (h g . h f) -<
18− y z . (y x)
15+ ( (h f . h g)
16+ -<
17+ (y x) . y z
18+ ) |||
19+ ( (h g . h f)
20+ -<
21+ y z . (y x)
22+ )
data/examples/declaration/value/function/arrow/proc-forms2.hs+6−6
@@ -4,16 +4,16 @@ bar0 f g h x =
44 proc (y, z) ->
55 (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)
66
7−bar1 f g x y = proc _ -> f -< x&&&g -< y
7+bar1 f g x y = proc _ -> (f -< x)&&&(g -< y)
88
99bar2 f g h x =
1010 proc (y, z) ->
11− h f.(h g) -< (y x).y z ||| (h g) . h f-<y z . (y x)
11+ (h f.(h g) -< (y x).y z) ||| ((h g) . h f-<y z . (y x))
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+ -< (y x).y z)
1717 |||
18− (h g . h f)
19− -<y z . (y x)
18+ ((h g . h f)
19+ -<y z . (y x))
data/examples/declaration/value/function/arrow/proc-ifs-out.hs+6−4
@@ -6,8 +6,10 @@ bar f g = proc a ->
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+10−4
@@ -4,7 +4,13 @@ foo x = if | x == 5 -> 5
44
55bar x y =
66 if
7− | x > y -> x
8− | x < y ->
9− y
10− | otherwise -> x
7+ | x > y -> x
8+ | x < y ->
9+ y
10+ | otherwise -> x
11+
12+baz =
13+ if
14+ | p -> f
15+ | otherwise -> g
16+ x
data/examples/declaration/value/function/multi-way-if.hs+5
@@ -7,3 +7,8 @@ bar x y = if
77 | x < y
88 -> y
99 | otherwise -> x
10+
11+baz =
12+ if | p -> f
13+ | otherwise -> g
14+ x
data/examples/declaration/value/function/operator-comments-2-out.hsnew file+5
@@ -0,0 +1,5 @@
1+x =
2+ y
3+ ++ f g -- commentA
4+ -- commentB
5+ -- commentC
data/examples/declaration/value/function/operator-comments-2.hsnew file+4
@@ -0,0 +1,4 @@
1+x =
2+ y ++ -- commentA
3+-- commentB
4+ f g -- commentC
data/examples/declaration/value/function/operators-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/overindentation-out.hs+11−9
@@ -1,9 +1,11 @@
1−reallyincrediblyLongName = f
2− a
3− A
4− { reallyincrediblyLongName = f
5− a
6− A
7− { reallyincrediblyLongName
8− }
9− }
1+reallyincrediblyLongName =
2+ f
3+ a
4+ A
5+ { reallyincrediblyLongName =
6+ f
7+ a
8+ A
9+ { reallyincrediblyLongName
10+ }
11+ }
data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs+8−8
@@ -1,8 +1,8 @@
1−( getNodeSettingsR :<|>
2− getNodeInfoR :<|>
3− getNextUpdateR :<|>
4− restartNodeR
5− ) :<|>
6− ( getUtxoR :<|>
7− getConfirmedProposalsR
8− ) = client nodeV1Api
1+( getNodeSettingsR
2+ :<|> getNodeInfoR
3+ :<|> getNextUpdateR
4+ :<|> restartNodeR
5+ )
6+ :<|> ( getUtxoR
7+ :<|> getConfirmedProposalsR
8+ ) = client nodeV1Api
data/examples/declaration/value/function/pattern/multiline-case-pattern-out.hs+2−2
@@ -10,6 +10,6 @@ f xs = case xs of
1010 ] -> a + b
1111
1212g xs = case xs of
13− ( a :
14− bs
13+ ( a
14+ : bs
1515 ) -> a + b
data/examples/declaration/value/function/pattern/view-pattern-out.hs−3
@@ -13,6 +13,3 @@ multiline
1313 bar
1414 baz
1515 ) = True
16−
17−-- https://github.com/tweag/ormolu/issues/343
18−foo = (f -> 4)
data/examples/declaration/value/function/pattern/view-pattern.hs−3
@@ -10,6 +10,3 @@ g ((f, _), f -> 4) = True
1010multiline (t -> Foo
1111 bar
1212 baz) = True
13−
14−-- https://github.com/tweag/ormolu/issues/343
15−foo = (f -> 4)
data/examples/declaration/value/function/record-constructors-out.hsdeleted−27
@@ -1,27 +0,0 @@
1−foo = Foo {a = 3}
2−
3−bar = Bar
4− { abc = foo,
5− def = Foo {a = 10}
6− }
7−
8−baz = Baz {}
9−
10−sym = Foo {(+) = 3}
11−
12−aLongVariableName =
13− ALongRecordName
14− { short = baz,
15− aLongRecordFieldName = YetAnotherLongRecordName
16− { yetAnotherLongRecordFieldName = "a long string"
17− },
18− aLongRecordFieldName2 = Just YetAnotherLongRecordName
19− { yetAnotherLongRecordFieldName = "a long string",
20− yetAnotherLongRecordFieldName =
21− Just
22− "a long string"
23− },
24− aLongRecordFieldName3 = do
25− foo
26− bar
27− }
data/examples/declaration/value/function/record/constructors-out.hsnew file+31
@@ -0,0 +1,31 @@
1+foo = Foo {a = 3}
2+
3+bar =
4+ Bar
5+ { abc = foo,
6+ def = Foo {a = 10}
7+ }
8+
9+baz = Baz {}
10+
11+sym = Foo {(+) = 3}
12+
13+aLongVariableName =
14+ ALongRecordName
15+ { short = baz,
16+ aLongRecordFieldName =
17+ YetAnotherLongRecordName
18+ { yetAnotherLongRecordFieldName = "a long string"
19+ },
20+ aLongRecordFieldName2 =
21+ Just
22+ YetAnotherLongRecordName
23+ { yetAnotherLongRecordFieldName = "a long string",
24+ yetAnotherLongRecordFieldName =
25+ Just
26+ "a long string"
27+ },
28+ aLongRecordFieldName3 = do
29+ foo
30+ bar
31+ }
data/examples/declaration/value/function/record-constructors.hs → data/examples/declaration/value/function/record/constructors.hsrenamed

The content is the same.

data/examples/declaration/value/function/record/dot-out.hsnew file+15
@@ -0,0 +1,15 @@
1+{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
2+
3+data Foo = Foo {bar :: Int}
4+
5+mfoo = fmap (.bar) $ Nothing
6+
7+bar = (Foo 1).bar
8+
9+fooplus f n = f{foo = f.bar + n}
10+
11+fooplus' f n = f {foo = f.bar + n}
12+
13+fooplus'' f n = f {foo = f.bar + n}
14+
15+fooplus''' f n = f {foo = f.bar + n}
data/examples/declaration/value/function/record/dot.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
2+data Foo = Foo { bar :: Int }
3+
4+mfoo = fmap (.bar) $ Nothing
5+
6+bar = ( Foo 1).bar
7+
8+fooplus f n = f{foo = f.bar + n}
9+
10+fooplus' f n = f { foo = f.bar + n}
11+
12+fooplus'' f n = f {foo = f.bar + n}
13+
14+fooplus''' f n = f{ foo = f.bar + n}
data/examples/declaration/value/function/record/hanging-after-equal-con-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ Foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-con.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = Foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record/hanging-after-equal-update-out.hsnew file+8
@@ -0,0 +1,8 @@
1+foo =
2+ foo
3+ { foo =
4+ -- Blah blah
5+ case x of
6+ Blah -> 1
7+ Blim -> 2
8+ }
data/examples/declaration/value/function/record/hanging-after-equal-update.hsnew file+7
@@ -0,0 +1,7 @@
1+foo = foo
2+ { foo =
3+ -- Blah blah
4+ case x of
5+ Blah -> 1
6+ Blim -> 2
7+ }
data/examples/declaration/value/function/record/inter-comments-out.hsnew file+13
@@ -0,0 +1,13 @@
1+x =
2+ Just
3+ -- comment
4+ A
5+ { x
6+ }
7+
8+x =
9+ Just
10+ -- comment
11+ a
12+ { x
13+ }
data/examples/declaration/value/function/record/inter-comments.hsnew file+11
@@ -0,0 +1,11 @@
1+x = Just
2+ -- comment
3+ A
4+ { x
5+ }
6+
7+x = Just
8+ -- comment
9+ a
10+ { x
11+ }
data/examples/declaration/value/function/record-updaters-out.hs → data/examples/declaration/value/function/record/updaters-out.hsrenamed

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/record-wildcards-out.hs → data/examples/declaration/value/function/record/wildcards-out.hsrenamed+7−6
@@ -3,11 +3,12 @@
33
44foo x y = Foo {x, y}
55
6−bar x y z = Bar
7− { x,
8− y,
9− z,
10− ..
11− }
6+bar x y z =
7+ Bar
8+ { x,
9+ y,
10+ z,
11+ ..
12+ }
1213
1314baz = Baz {..}
data/examples/declaration/value/function/record-wildcards.hs → data/examples/declaration/value/function/record/wildcards.hsrenamed

The content is the same.

data/examples/declaration/value/function/type-applications-and-splice-out.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [|sing @ $(symFQN name)|]
data/examples/declaration/value/function/type-applications-and-splice.hsnew file+4
@@ -0,0 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TypeApplications #-}
3+
4+staticKey name = [| sing @ $(symFQN name) |]
data/examples/declaration/value/function/type-applications-out.hs+6
@@ -8,3 +8,9 @@ baz =
88 f @Int @String
99 a
1010 b
11+
12+goo =
13+ hash
14+ @(HASH TPraosStandardCrypto)
15+ @ByteString
16+ "And the lamb lies down on Broadway"
data/examples/declaration/value/function/type-applications.hs+5
@@ -6,3 +6,8 @@ bar = f @(Maybe Int) a b
66
77baz = f @Int @String
88 a b
9+
10+goo = hash
11+ @(HASH TPraosStandardCrypto)
12+ @ByteString
13+ "And the lamb lies down on Broadway"
data/examples/import/deduplication-bug-out.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1 (..), Baz1)
2+import Foo2 (Bar2 (..), Baz2)
3+import Foo3 (Bar3 (x1, x2, x3))
4+import Foo4 (Bar4 (x1, x2))
5+import Foo5 (Bar5 (x1))
6+import Foo6 (Bar6 (..))
data/examples/import/deduplication-bug.hsnew file+6
@@ -0,0 +1,6 @@
1+import Foo1 (Bar1, Baz1, Bar1(..))
2+import Foo2 (Bar2(..), Baz2, Bar2)
3+import Foo3 (Bar3(x1,x3), Bar3(x1, x2))
4+import Foo4 (Bar4(x1), Bar4(x2))
5+import Foo5 (Bar5, Bar5(x1))
6+import Foo6 (Bar6(x1), Bar6(..))
data/examples/import/explicit-imports-out.hs+4−4
@@ -1,12 +1,12 @@
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.hsnew file+5
@@ -0,0 +1,5 @@
1+{-# LANGUAGE ImportQualifiedPost #-}
2+
3+import Data.Text qualified (a, b, c)
4+import Data.Text qualified hiding (a, b, c)
5+import Data.Text qualified as T
data/examples/import/qualified-post.hsnew file+5
@@ -0,0 +1,5 @@
1+{-# LANGUAGE ImportQualifiedPost #-}
2+
3+import qualified Data.Text as T
4+import qualified Data.Text (a, c, b)
5+import Data.Text qualified hiding (c, b, a)
data/examples/import/qualified-prelude-out.hs+1−1
@@ -1,4 +1,4 @@
11module P where
22
3−import Prelude hiding ((.), id)
3+import Prelude hiding (id, (.))
44import qualified Prelude
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-alignment-out.hs−1
@@ -1,5 +1,4 @@
11class Foo a where
2−
32 -- | Foo.
43 foo ::
54 Int ->
data/examples/other/comment-before-hanging-out.hsnew file+5
@@ -0,0 +1,5 @@
1+x = Just
2+ -- comment
3+ do
4+ foo
5+ bar
data/examples/other/comment-before-hanging.hsnew file+5
@@ -0,0 +1,5 @@
1+x = Just
2+ -- comment
3+ do
4+ foo
5+ bar
data/examples/other/comment-glued-together-out.hsnew file+7
@@ -0,0 +1,7 @@
1+module Main (main) where
2+
3+-- | Foo.
4+
5+-- Bar
6+main :: IO ()
7+main = return ()
data/examples/other/comment-glued-together.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+{- | Foo. -}
4+-- Bar
5+main :: IO ()
6+main = return ()
data/examples/other/comment-trailing-space-out.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-trailing-space.hsnew file+9
@@ -0,0 +1,9 @@
1+data T
2+ = {-
3+
4+ some multi-line comment
5+
6+ with empty lines
7+
8+ -}
9+ A
data/examples/other/comment-two-blocks-out.hs+2−2
@@ -2,7 +2,7 @@ newNames :: [(String, String)]
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−51
@@ -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,57 +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.8.1. We disable Haddock generation because it's way
21− # too slow.
22− "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
23− (super.callHackage "ghc-lib-parser" "8.8.1" { });
19+ "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };
2420 };
2521 ormolize = import ./nix/ormolize {
2622 inherit pkgs;
2723 inherit haskellPackages;
2824 };
29− # NOTE We have to exclude some directories for some packages because
30− # Ormolu needs files to be parsable by Haddock which is not always the
31− # case. For example some tests and examples do not parse.
32− excludedHackageDirs = {
33− "aws" = ["Examples"];
34− "distributed-process" = ["benchmarks"];
35− "esqueleto" = ["test"];
36− "fay" = ["examples"];
37− "postgrest" = ["test"];
38− };
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"]);
3941 ormolizedPackages = doCheck:
4042 pkgs.lib.mapAttrs (name: p: ormolize {
4143 package = p;
4244 inherit doCheck;
43− excludedDirs =
44− if builtins.hasAttr name excludedHackageDirs
45− then excludedHackageDirs.${name}
46− else [];
45+ expectedFailures =
46+ if pkgs.lib.lists.any (x: x == name) expectedFailures
47+ then ./expected-failures + "/${name}.txt"
48+ else null;
4749 }) haskellPackages;
4850in {
4951 ormolu = haskellPackages.ormolu;
50− ormoluShell = haskellPackages.shellFor {
51− packages = ps: [
52− ps.ormolu
53− ];
54− buildInputs = [
55− haskellPackages.cabal-install
56− haskellPackages.ghcid
57− ];
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+ };
5872 };
5973 inherit ormoluOverlay ormoluCompiler;
6074 hackage = ormolizedPackages false;
6175 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
6276 let ps = [
77+ "Agda"
6378 "QuickCheck"
6479 "ShellCheck"
6580 "aeson"
6681 "attoparsec"
6782 "aws"
83+ "brick"
6884 "capability"
6985 "cassava"
7086 "conduit"
@@ -76,37 +92,78 @@ in {
7692 "hakyll"
7793 "haxl"
7894 "hedgehog"
95+ "hledger"
7996 "hlint"
97+ "http-client"
98+ "idris"
99+ "intero"
100+ "leksah"
101+ "lens"
80102 "megaparsec"
81− "ormolu"
82103 "optics"
104+ "ormolu"
105+ "pandoc"
106+ "parsec3"
107+ "pipes"
83108 "postgrest"
109+ "purescript"
84110 "servant"
85111 "servant-server"
112+ "stack"
86113 "tensorflow"
87114 "text_1_2_4_0"
88115 "tls"
89116 "yesod-core"
90−
91− # Comment idempotence issue
92−
93− # "Agda"
94− # "brick"
95− # "hledger"
96− # "http-client"
97− # "idris"
98− # "intero"
99− # "leksah"
100− # "pandoc"
101− # "pipes"
102− # "stack"
103−
104− # Missing language extension
105−
106− # "lens" #fixed in master
107− # "purescript"
108−
109117 ];
110118 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
111119 );
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+ };
112169}
expected-failures/Agda.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17
3+ before: " = (check_ac"
4+ after: " =\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4
9+ before: " nes\n\n "
10+ after: " nes\n\n -- Andreas"
11+Please, consider reporting the bug.
expected-failures/aws.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ Examples/PutBucketNearLine.hs:5:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ Examples/Sqs.hs:(88,3)-(90,4)
7+ parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when
8+ | the program ends as when it started.
9+ -}'
expected-failures/distributed-process.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmarks/Channels.hs:2:1-6
3+ parse error on input `import'
4+
5+The GHC parser (in Haddock mode) failed:
6+ benchmarks/Spawns.hs:5:1-6
7+ parse error on input `import'
expected-failures/esqueleto.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Database/Esqueleto/Internal/Internal.hs:379:1
3+ lexical error in string/character literal at character 's'
4+
5+The GHC parser (in Haddock mode) failed:
6+ test/PostgreSQL/Test.hs:562:9-41
7+ parse error on input `-- | Check the result is not null'
expected-failures/fay.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ examples/Separated.hs:12:1-6
3+ parse error on input `module'
4+
5+The GHC parser (in Haddock mode) failed:
6+ examples/calc.hs:(4,1)-(6,2)
7+ parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs
8+-- You also need to download jquery.min.js.
9+--'
10+
11+The GHC parser (in Haddock mode) failed:
12+ examples/canvaswater.hs:(6,1)-(7,17)
13+ parse error on input `-- | A demonstration of Fay using the canvas element to display a
14+-- simple effect.'
15+
16+The GHC parser (in Haddock mode) failed:
17+ examples/data.hs:9:1-6
18+ parse error on input `module'
expected-failures/hlint.txtnew file+11
@@ -0,0 +1,11 @@
1+Formatting is not idempotent:
2+ src/Extension.hs<rendered>:19:22
3+ before: "DoRec , -} Recursive"
4+ after: "DoRec , -}\n "
5+Please, consider reporting the bug.
6+
7+Formatting is not idempotent:
8+ src/Hint/Bracket.hs<rendered>:249:50
9+ before: "\" x y [r]) {ideaSpan"
10+ after: "\" x y [r])\n "
11+Please, consider reporting the bug.
expected-failures/idris.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Idris/Parser.hs:1052:1
3+ parse error on input `@'
4+
5+The GHC parser (in Haddock mode) failed:
6+ src/Idris/Parser/Expr.hs:75:1
7+ parse error on input `@'
expected-failures/intero.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/InteractiveUI.hs<rendered>:3748:33
3+ before: "text \"Try\" <+> doWha"
4+ after: "text \"Try\"\n "
5+Please, consider reporting the bug.
expected-failures/leksah.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/IDE/Pane/Modules.hs<rendered>:1184:7
3+ before: "cr\n -- show"
4+ after: "cr\n in -- show"
5+Please, consider reporting the bug.
expected-failures/lens.txtnew file+3
@@ -0,0 +1,3 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Control/Exception/Lens.hs:180:13-37
3+ parse error on input `AllocationLimitExceeded__'
expected-failures/pandoc.txtnew file+9
@@ -0,0 +1,9 @@
1+The GHC parser (in Haddock mode) failed:
2+ benchmark/weigh-pandoc.hs:14:1-6
3+ parse error on input `import'
4+
5+Formatting is not idempotent:
6+ src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:613:19
7+ before: ".softbreak <$ endlin"
8+ after: ".softbreak\n <$ en"
9+Please, consider reporting the bug.
expected-failures/pipes.txtnew file+3
@@ -0,0 +1,3 @@
1+AST of input and AST of formatted code differ.
2+ at src/Pipes/Core.hs:(128,1)-(151,2)
3+Please, consider reporting the bug.
expected-failures/postgrest.txtnew file+5
@@ -0,0 +1,5 @@
1+Formatting is not idempotent:
2+ src/PostgREST/DbRequestBuilder.hs<rendered>:149:24
3+ before: " || -- clients"
4+ after: " || ( origin ="
5+Please, consider reporting the bug.
expected-failures/purescript.txtnew file+18
@@ -0,0 +1,18 @@
1+The GHC parser (in Haddock mode) failed:
2+ src/Language/PureScript/AST/Declarations.hs:479:1-17
3+ Invalid type signature: pattern ValueDecl :: ...
4+Perhaps you meant to use PatternSynonyms?
5+
6+The GHC parser (in Haddock mode) failed:
7+ src/Language/PureScript/AST/SourcePos.hs:99:1-22
8+ Invalid type signature: pattern NullSourceSpan :: ...
9+Perhaps you meant to use PatternSynonyms?
10+
11+The GHC parser (in Haddock mode) failed:
12+ src/Language/PureScript/Constants.hs:42:1-15
13+ Invalid type signature: pattern Discard :: ...
14+Perhaps you meant to use PatternSynonyms?
15+
16+The GHC parser (in Haddock mode) failed:
17+ src/Language/PureScript/Crash.hs:16:1-6
18+ parse error on input `import'
expected-failures/tensorflow.txtnew file+7
@@ -0,0 +1,7 @@
1+The GHC parser (in Haddock mode) failed:
2+ tensorflow-mnist/app/Main.hs:50:13-14
3+ parse error on input `->'
4+
5+The GHC parser (in Haddock mode) failed:
6+ tensorflow-ops/tests/RegressionTest.hs:3:1-6
7+ parse error on input `import'
format.sh+6−3
@@ -1,5 +1,5 @@
11#!/usr/bin/env nix-shell
2−#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure
2+#!nix-shell default.nix -A dev.withOrmolu -i bash --pure
33#
44# Format Ormolu using current version of Ormolu.
55
@@ -7,5 +7,8 @@ set -e
77
88export LANG="C.UTF-8"
99
10−ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
11−ormolu --mode 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−157
@@ -1,167 +1,184 @@
1−name: ormolu
2−version: 0.0.2.0
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.8.1 && < 8.8.2
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− -Wnoncanonical-monadfail-instances
120− -- https://github.com/haskell/haddock/issues/1116
121− -Wno-missing-home-modules
122− else
123− ghc-options: -O2 -Wall
124− 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
125111
126−test-suite tests
127− main-is: Spec.hs
128− hs-source-dirs: tests
129− type: exitcode-stdio-1.0
130− build-depends: base >= 4.12 && < 5.0
131− , containers >= 0.5 && < 0.7
132− , filepath >= 1.2 && < 1.5
133− , hspec >= 2.0 && < 3.0
134− , ormolu
135− , path >= 0.6 && < 0.7
136− , path-io >= 1.4.2 && < 2.0
137− , text >= 0.2 && < 1.3
138− build-tools: hspec-discover >= 2.0 && < 3.0
139− other-modules:
140− Ormolu.Parser.PragmaSpec
141− , 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
142128
143− if flag(dev)
144− ghc-options: -Wall -Werror
145− else
146− ghc-options: -O2 -Wall
147− 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
148137
149138executable ormolu
150− main-is: Main.hs
151− hs-source-dirs: app
152− build-depends: base >= 4.12 && < 5.0
153− , ghc-lib-parser >= 8.8.1 && < 8.8.2
154− , gitrev >= 1.3 && < 1.4
155− , optparse-applicative >= 0.14 && < 0.15
156− , ormolu
157− , text >= 0.2 && < 1.3
158− other-modules: Paths_ormolu
159− if flag(dev)
160− ghc-options: -Wall -Werror -Wcompat
161− -Wincomplete-record-updates
162− -Wincomplete-uni-patterns
163− -Wnoncanonical-monad-instances
164− -Wnoncanonical-monadfail-instances
165− else
166− ghc-options: -O2 -Wall
167− 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+2−13
@@ -1,23 +1,12 @@
11module GHC
22 ( module X,
3− ParsedSource,
43 )
54where
65
76import ApiAnnotation as X
87import BasicTypes as X
9−import HsBinds as X
10−import HsDecls as X
11−import HsDoc as X
12−import HsExpr as X
13−import HsExtension as X
14−import HsImpExp as X
15−import HsInstances as X ()
16−import HsLit as X
17−import HsPat as X
18−import HsSyn as X
8+import GHC.Hs as X
9+import GHC.Hs.Instances as X ()
1910import Module as X
2011import RdrName as X
2112import SrcLoc as X
22−
23−type ParsedSource = Located (HsModule GhcPs)
src/GHC/DynFlags.hs+33−20
@@ -1,5 +1,7 @@
11{-# OPTIONS_GHC -Wno-missing-fields #-}
22
3+-- Modified from ghc-lib-api-ext.
4+
35module GHC.DynFlags
46 ( baseDynFlags,
57 )
@@ -8,29 +10,40 @@ where
810import Config
911import DynFlags
1012import Fingerprint
11−import Platform
13+import GHC.Platform
14+import ToolSettings
1215
13−-- | Taken from HLint.
1416fakeSettings :: Settings
15−fakeSettings = Settings
16− { sTargetPlatform = platform,
17− sPlatformConstants = platformConstants,
18− sProjectVersion = cProjectVersion,
19− sProgramName = "ghc",
20− sOpt_P_fingerprint = fingerprint0
21− }
22− where
23− platform =
24− Platform
25− { platformWordSize = 8,
26− platformOS = OSUnknown,
27− platformUnregisterised = True
28− }
29− platformConstants =
30− PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}
17+fakeSettings =
18+ Settings
19+ { sGhcNameVersion =
20+ GhcNameVersion
21+ { ghcNameVersion_programName = "ghc",
22+ ghcNameVersion_projectVersion = cProjectVersion
23+ },
24+ sFileSettings = FileSettings {},
25+ sTargetPlatform =
26+ Platform
27+ { platformWordSize = PW8,
28+ platformMini =
29+ PlatformMini
30+ { platformMini_arch = ArchUnknown,
31+ platformMini_os = OSUnknown
32+ },
33+ platformUnregisterised = True
34+ },
35+ sPlatformMisc = PlatformMisc {},
36+ sPlatformConstants =
37+ PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},
38+ sToolSettings =
39+ ToolSettings
40+ { toolSettings_opt_P_fingerprint = fingerprint0,
41+ toolSettings_pgm_F = ""
42+ }
43+ }
3144
32−fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
33−fakeLlvmConfig = ([], [])
45+fakeLlvmConfig :: LlvmConfig
46+fakeLlvmConfig = LlvmConfig [] []
3447
3548baseDynFlags :: DynFlags
3649baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
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+67−27
@@ -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,38 +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+ }
2840 deriving (Eq, Show)
2941
30−-- | Default 'Config'.
31−defaultConfig :: Config
32−defaultConfig = Config
33− { cfgDynOptions = [],
34− cfgUnsafe = False,
35− cfgDebug = False,
36− cfgTolerateCpp = False,
37− cfgCheckIdempotency = False
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
3849 }
50+ deriving (Eq, Show)
51+
52+-- | Default @'Config' 'RegionIndices'@.
53+defaultConfig :: Config RegionIndices
54+defaultConfig =
55+ Config
56+ { cfgDynOptions = [],
57+ cfgUnsafe = False,
58+ cfgDebug = False,
59+ cfgCheckIdempotence = False,
60+ cfgRegion =
61+ RegionIndices
62+ { regionStartLine = Nothing,
63+ regionEndLine = Nothing
64+ }
65+ }
66+
67+-- | Convert 'RegionIndices' into 'RegionDeltas'.
68+regionIndicesToDeltas ::
69+ -- | Total number of lines in the input
70+ Int ->
71+ -- | Region indices
72+ RegionIndices ->
73+ -- | Region deltas
74+ RegionDeltas
75+regionIndicesToDeltas total RegionIndices {..} =
76+ RegionDeltas
77+ { regionPrefixLength = maybe 0 (subtract 1) regionStartLine,
78+ regionSuffixLength = maybe 0 (total -) regionEndLine
79+ }
3980
4081-- | A wrapper for dynamic options.
41−newtype DynOption
42− = DynOption
43− { unDynOption :: String
44− }
82+newtype DynOption = DynOption
83+ { unDynOption :: String
84+ }
4585 deriving (Eq, Ord, Show)
4686
4787-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
src/Ormolu/Diff.hs+23−13
@@ -8,14 +8,14 @@ module Ormolu.Diff
88 )
99where
1010
11−import BasicTypes (SourceText)
1211import Data.ByteString (ByteString)
1312import Data.Generics
1413import Data.Text (Text)
1514import qualified Data.Text as T
1615import qualified FastString as GHC
1716import GHC
18−import Ormolu.Imports (sortImports)
17+import Ormolu.Imports (normalizeImports)
18+import Ormolu.Parser.CommentStream
1919import Ormolu.Parser.Result
2020import Ormolu.Utils
2121
@@ -39,14 +39,16 @@ diffParseResult :: ParseResult -> ParseResult -> Diff
3939diffParseResult
4040 ParseResult
4141 { prCommentStream = cstream0,
42− prParsedSource = ps0
42+ prParsedSource = hs0
4343 }
4444 ParseResult
4545 { prCommentStream = cstream1,
46− prParsedSource = ps1
46+ prParsedSource = hs1
4747 } =
4848 matchIgnoringSrcSpans cstream0 cstream1
49− <> matchIgnoringSrcSpans ps0 ps1
49+ <> matchIgnoringSrcSpans
50+ hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}
51+ hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}
5052
5153-- | Compare two values for equality disregarding differences in 'SrcSpan's
5254-- and the ordering of import lists.
@@ -68,9 +70,10 @@ matchIgnoringSrcSpans = genericQuery
6870 gzipWithQ
6971 ( genericQuery
7072 `extQ` srcSpanEq
71− `extQ` hsModuleEq
73+ `extQ` commentEq
7274 `extQ` sourceTextEq
7375 `extQ` hsDocStringEq
76+ `extQ` importDeclQualifiedStyleEq
7477 `ext2Q` forLocated
7578 )
7679 x
@@ -78,16 +81,23 @@ 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
94+ importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff
95+ importDeclQualifiedStyleEq d0 d1' =
96+ case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of
97+ (x, Just x') | x == x' -> Same
98+ (QualifiedPre, Just QualifiedPost) -> Same
99+ (QualifiedPost, Just QualifiedPre) -> Same
100+ _ -> Different []
91101 hsDocStringEq :: HsDocString -> GenericQ Diff
92102 hsDocStringEq str0 str1' =
93103 case cast str1' :: Maybe HsDocString of
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+168−51
@@ -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)
16−import HsExtension
17−import HsImpExp (IE (..))
18−import Ormolu.Utils (notImplemented)
19+import GHC.Hs.Extension
20+import GHC.Hs.ImpExp (IE (..))
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 {} -> notImplemented "XImportDecl"
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 NoExt x w xs fl ->
55− IEThingWith NoExt 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 NoExt x -> unLoc x
66− IEThingAbs NoExt x -> unLoc x
67− IEThingAll NoExt x -> unLoc x
68− IEThingWith NoExt x _ _ _ -> unLoc x
69− IEModuleContents NoExt _ -> notImplemented "IEModuleContents"
70− IEGroup NoExt _ _ -> notImplemented "IEGroup"
71− IEDoc NoExt _ -> notImplemented "IEDoc"
72− IEDocNamed NoExt _ -> notImplemented "IEDocNamed"
73− XIE NoExt -> notImplemented "XIE"
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)
167+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"
168+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"
169+ IEDoc NoExtField _ -> notImplemented "IEDoc"
170+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"
171+ XIE x -> noExtCon x
172+
173+-- | Like 'compareIewn' for located wrapped names.
174+compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering
175+compareLIewn = compareIewn `on` unLoc
74176
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+84−84
@@ -9,15 +9,16 @@ module Ormolu.Parser
99 )
1010where
1111
12+import Bag (bagToList)
1213import qualified CmdLineParser as GHC
1314import Control.Exception
14−import Control.Monad
1515import Control.Monad.IO.Class
16−import Data.List ((\\), foldl', isPrefixOf)
16+import qualified Data.List as L
1717import qualified Data.List.NonEmpty as NE
18−import Data.Maybe (catMaybes)
19−import qualified DynFlags as GHC
18+import Data.Ord (Down (Down))
19+import qualified Data.Text as T
2020import DynFlags as GHC
21+import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
2122import qualified FastString as GHC
2223import GHC hiding (IE, UnicodeSyntax)
2324import GHC.DynFlags (baseDynFlags)
@@ -30,7 +31,8 @@ import Ormolu.Exception
3031import Ormolu.Parser.Anns
3132import Ormolu.Parser.CommentStream
3233import Ormolu.Parser.Result
33−import qualified Outputable as GHC
34+import Ormolu.Processing.Preprocess (preprocess)
35+import Ormolu.Utils (incSpanLine, removeIndentation)
3436import qualified Panic as GHC
3537import qualified Parser as GHC
3638import qualified StringBuffer as GHC
@@ -39,7 +41,7 @@ import qualified StringBuffer as GHC
3941parseModule ::
4042 MonadIO m =>
4143 -- | Ormolu configuration
42− Config ->
44+ Config RegionDeltas ->
4345 -- | File name (only for source location annotations)
4446 FilePath ->
4547 -- | Input for parser
@@ -48,8 +50,10 @@ parseModule ::
4850 ( [GHC.Warn],
4951 Either (SrcSpan, String) ParseResult
5052 )
51−parseModule Config {..} path input' = liftIO $ do
52− 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
5357 -- It's important that 'setDefaultExts' is done before
5458 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
5559 -- extension that was explicitly disabled in the file.
@@ -59,7 +63,7 @@ parseModule Config {..} path input' = liftIO $ do
5963 (setDefaultExts baseDynFlags)
6064 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
6165 (warnings, dynFlags) <-
62− parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case
66+ parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case
6367 Right res -> pure res
6468 Left err ->
6569 let loc =
@@ -67,22 +71,59 @@ parseModule Config {..} path input' = liftIO $ do
6771 (mkSrcLoc (GHC.mkFastString path) 1 1)
6872 (mkSrcLoc (GHC.mkFastString path) 1 1)
6973 in throwIO (OrmoluParsingFailed loc err)
70− when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
71− throwIO (OrmoluCppEnabled path)
72− let r = case runParser GHC.parseModule dynFlags path input of
73− GHC.PFailed _ ss m ->
74− Left (ss, GHC.showSDoc dynFlags m)
75− GHC.POk pstate pmod ->
76− let (comments, exts, shebangs) = mkCommentStream extraComments pstate
77− in Right ParseResult
78− { prParsedSource = pmod,
79− prAnns = mkAnns pstate,
80− prCommentStream = comments,
81− prExtensions = exts,
82− prShebangs = shebangs
83− }
74+ let useRecordDot =
75+ "record-dot-preprocessor" == pgm_F dynFlags
76+ || any
77+ (("RecordDotPreprocessor" ==) . moduleNameString)
78+ (pluginModNames dynFlags)
79+ pStateErrors = \pstate ->
80+ let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
81+ fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)
82+ in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of
83+ [] -> Nothing
84+ err : _ ->
85+ -- Show instance returns a short error message
86+ Just (fixupErrSpan (errMsgSpan err), show err)
87+ r = case runParser GHC.parseModule dynFlags path input of
88+ GHC.PFailed pstate ->
89+ case pStateErrors pstate of
90+ Just err -> Left err
91+ Nothing -> error "PFailed does not have an error"
92+ GHC.POk pstate (L _ hsModule) ->
93+ case pStateErrors pstate of
94+ -- Some parse errors (pattern/arrow syntax in expr context)
95+ -- do not cause a parse error, but they are replaced with "_"
96+ -- by the parser and the modified AST is propagated to the
97+ -- later stages; but we fail in those cases.
98+ Just err -> Left err
99+ Nothing ->
100+ let (stackHeader, shebangs, pragmas, comments) =
101+ mkCommentStream input extraComments pstate
102+ in Right
103+ ParseResult
104+ { prParsedSource = hsModule,
105+ prAnns = mkAnns pstate,
106+ prStackHeader = stackHeader,
107+ prShebangs = shebangs,
108+ prPragmas = pragmas,
109+ prCommentStream = comments,
110+ prUseRecordDot = useRecordDot,
111+ prImportQualifiedPost =
112+ GHC.xopt ImportQualifiedPost dynFlags,
113+ prLiteralPrefix = T.pack literalPrefix,
114+ prLiteralSuffix = T.pack literalSuffix,
115+ prIndent = indent
116+ }
84117 return (warnings, r)
85118
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+
86127-- | Extensions that are not enabled automatically and should be activated
87128-- by user.
88129manualExts :: [Extension]
@@ -102,14 +143,13 @@ manualExts =
102143 MonadComprehensions,
103144 UnboxedSums,
104145 UnicodeSyntax, -- gives special meanings to operators like (→)
105− TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
146+ TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this
106147 -- apparently interferes with QuasiQuotes in
107148 -- weird ways
149+ ImportQualifiedPost -- affects how Ormolu renders imports, so the
150+ -- decision of enabling this style is left to the user
108151 ]
109152
110−----------------------------------------------------------------------------
111−-- Helpers (taken from ghc-exactprint)
112−
113153-- | Run a 'GHC.P' computation.
114154runParser ::
115155 -- | Computation to run
@@ -128,67 +168,27 @@ runParser parser flags filename input = GHC.unP parser parseState
128168 buffer = GHC.stringToStringBuffer input
129169 parseState = GHC.mkPState flags buffer location
130170
131−-- | Transform given lines possibly returning comments extracted from them.
132−-- This handles LINE pragmas and shebangs.
133−extractCommentsFromLines ::
134− -- | File name, just to use in the spans
135− FilePath ->
136− -- | List of lines from that file
137− String ->
138− -- | Adjusted lines together with comments extracted from them
139− (String, [Located String])
140−extractCommentsFromLines path =
141− unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines
142− where
143− unlines' (a, b) = (unlines a, catMaybes b)
171+-- | Wrap GHC's 'Severity' to add 'Ord' instance.
172+newtype SeverityOrd = SeverityOrd Severity
144173
145−-- | Transform a given line possibly returning a comment extracted from it.
146−extractCommentFromLine ::
147− -- | File name, just to use in the spans
148− FilePath ->
149− -- | Line number of this line
150− Int ->
151− -- | The actual line
152− String ->
153− -- | Adjusted line and possibly a comment extracted from it
154− (String, Maybe (Located String))
155−extractCommentFromLine path line s
156− | "{-# LINE" `isPrefixOf` s =
157− let (pragma, res) = getPragma s
158− size = length pragma
159− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
160− in (res, Just $ L ss pragma)
161− | isShebang s =
162− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
163− in ("", Just $ L ss s)
164− | otherwise = (s, Nothing)
165− where
166− mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
167−
168−-- | Take a line pragma and output its replacement (where line pragma is
169−-- replaced with spaces) and the contents of the pragma itself.
170−getPragma ::
171− -- | Pragma line to analyze
172− String ->
173− -- | Contents of the pragma and its replacement line
174− (String, String)
175−getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
176−getPragma s@(x : xs)
177− | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
178− | otherwise =
179− let (prag, remline) = getPragma xs
180− in (x : prag, ' ' : remline)
174+instance Eq SeverityOrd where
175+ s1 == s2 = compare s1 s2 == EQ
181176
182−-- | Enable all language extensions that we think should be enabled by
183−-- default for ease of use.
184−setDefaultExts :: DynFlags -> DynFlags
185−setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
186− where
187− autoExts = allExts \\ manualExts
188− 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
189189
190190----------------------------------------------------------------------------
191−-- More helpers (taken from HLint)
191+-- Helpers taken from HLint
192192
193193parsePragmasIntoDynFlags ::
194194 -- | Pre-set 'DynFlags'
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−13
@@ -7,25 +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− }
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+ }
2942
3043-- | Pretty-print a 'ParseResult'.
3144prettyPrintParseResult :: 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−5
@@ -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,8 +20,19 @@ printModule ::
1920 -- | Resulting rendition
2021 Text
2122printModule ParseResult {..} =
22− runR
23− (p_hsModule prShebangs prExtensions prParsedSource)
24− (mkSpanStream prParsedSource)
25− prCommentStream
26− prAnns
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−53
@@ -21,9 +21,9 @@ module Ormolu.Printer.Combinators
2121 space,
2222 newline,
2323 inci,
24+ inciIf,
2425 located,
2526 located',
26− locatedPat,
2727 switchLayout,
2828 Layout (..),
2929 vlayout,
@@ -52,58 +52,57 @@ module Ormolu.Printer.Combinators
5252
5353 -- ** Literals
5454 comma,
55+ commaDel,
56+ equals,
5557
56− -- ** Comments
58+ -- ** Stateful markers
59+ SpanMark (..),
60+ spanMarkSpan,
5761 HaddockStyle (..),
58− setLastCommentSpan,
59− getLastCommentSpan,
62+ setSpanMark,
63+ getSpanMark,
6064 )
6165where
6266
6367import Control.Monad
64−import Data.Data (Data)
6568import Data.List (intersperse)
6669import Data.Text (Text)
67−import GHC (Pat (XPat), XXPat)
6870import Ormolu.Printer.Comments
6971import Ormolu.Printer.Internal
70−import Ormolu.Utils (isModule)
7172import SrcLoc
7273
7374----------------------------------------------------------------------------
7475-- Basic
7576
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+
7686-- | Enter a 'Located' entity. This combinator handles outputting comments
7787-- and sets layout (single-line vs multi-line) for the inner computation.
7888-- Roughly, the rule for using 'located' is that every time there is a
7989-- 'Located' wrapper, it should be “discharged” with a corresponding
8090-- 'located' invocation.
8191located ::
82− Data a =>
8392 -- | Thing to enter
8493 Located a ->
8594 -- | How to render inner value
8695 (a -> R ()) ->
8796 R ()
88−located loc f = do
89− let withRealLocated (L l a) g =
90− case l of
91− UnhelpfulSpan _ -> return ()
92− RealSrcSpan l' -> g (L l' a)
93− withRealLocated loc spitPrecedingComments
94− let setEnclosingSpan =
95− case getLoc loc of
96− UnhelpfulSpan _ -> id
97− RealSrcSpan orf ->
98− if isModule (unLoc loc)
99− then id
100− else withEnclosingSpan orf
101− setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))
102− 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
103103
104104-- | A version of 'located' with arguments flipped.
105105located' ::
106− Data a =>
107106 -- | How to render inner value
108107 (a -> R ()) ->
109108 -- | Thing to enter
@@ -111,28 +110,6 @@ located' ::
111110 R ()
112111located' = flip located
113112
114−-- | A version of 'located' that works on 'Pat'.
115−--
116−-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always
117−-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.
118−--
119−-- Most of the time, we can just use 'p_pat' directly, because it handles
120−-- located 'Pat's. However, sometimes we want to use the location to render
121−-- something other than the given 'Pat'.
122−--
123−-- If given 'Pat' does not contain a location, we error out.
124−--
125−-- This should become unnecessary if
126−-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.
127−locatedPat ::
128− (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
129− Pat pass ->
130− (Pat pass -> R ()) ->
131− R ()
132−locatedPat p f = case p of
133− XPat pat -> located pat f
134− _ -> error "locatedPat: Pat does not contain a location"
135−
136113-- | Set layout according to combination of given 'SrcSpan's for a given.
137114-- Use this only when you need to set layout based on e.g. combined span of
138115-- several elements when there is no corresponding 'Located' wrapper
@@ -208,10 +185,12 @@ sepSemi f xs = vlayout singleLine multiLine
208185 xs' ->
209186 if ub
210187 then do
211− txt "{ "
212− sep (txt "; ") (dontUseBraces . f) xs'
213− txt " }"
214− 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'
215194 multiLine =
216195 sep newline (dontUseBraces . f) xs
217196
@@ -224,6 +203,7 @@ data BracketStyle
224203 N
225204 | -- | Shifted one level
226205 S
206+ deriving (Eq, Show)
227207
228208-- | Surround given entity by backticks.
229209backticks :: R () -> R ()
@@ -300,9 +280,7 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
300280 then newline >> inci m
301281 else space >> sitcc m
302282 newline
303− case style of
304− N -> txt close
305− S -> inci (txt close)
283+ inciIf (style == S) (txt close)
306284
307285----------------------------------------------------------------------------
308286-- Literals
@@ -310,3 +288,11 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
310288-- | Print @,@.
311289comma :: R ()
312290comma = 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+173−108
@@ -1,4 +1,5 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RankNTypes #-}
45
@@ -13,10 +14,11 @@ module Ormolu.Printer.Internal
1314
1415 -- * Internal functions
1516 txt,
17+ interferingTxt,
1618 atom,
1719 space,
1820 newline,
19− isLineDirty,
21+ useRecordDot,
2022 inci,
2123 sitcc,
2224 Layout (..),
@@ -37,9 +39,14 @@ module Ormolu.Printer.Internal
3739 popComment,
3840 getEnclosingSpan,
3941 withEnclosingSpan,
42+ thisLineSpans,
43+
44+ -- * Stateful markers
45+ SpanMark (..),
46+ spanMarkSpan,
4047 HaddockStyle (..),
41− setLastCommentSpan,
42− getLastCommentSpan,
48+ setSpanMark,
49+ getSpanMark,
4350
4451 -- * Annotations
4552 getAnns,
@@ -72,43 +79,44 @@ newtype R a = R (ReaderT RC (State SC) a)
7279
7380-- | Reader context of 'R'. This should be used when we control rendering by
7481-- enclosing certain expressions with wrappers.
75−data RC
76− = RC
77− { -- | Indentation level, as the column index we need to start from after
78− -- a newline if we break lines
79− rcIndent :: !Int,
80− -- | Current layout
81− rcLayout :: Layout,
82− -- | Spans of enclosing elements of AST
83− rcEnclosingSpans :: [RealSrcSpan],
84− -- | Collection of annotations
85− rcAnns :: Anns,
86− -- | If the last expression in the layout can use braces
87− rcCanUseBraces :: Bool
88− }
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+ }
8997
9098-- | State context of 'R'.
91−data SC
92− = SC
93− { -- | Index of the next column to render
94− scColumn :: !Int,
95− -- | Rendered source code so far
96− scBuilder :: Builder,
97− -- | Span stream
98− scSpanStream :: SpanStream,
99− -- | Comment stream
100− scCommentStream :: CommentStream,
101− -- | Pending comment lines (in reverse order) to be inserted before next
102− -- newline, 'Int' is the indentation level
103− scPendingComments :: ![(CommentPosition, Int, Text)],
104− -- | Whether the current line is “dirty”, that is, already contains
105− -- atoms that can have comments attached to them
106− scDirtyLine :: !Bool,
107− -- | Whether to output a space before the next output
108− scRequestedDelimiter :: !RequestedDelimiter,
109− -- | Span of last output comment
110− scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
111− }
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+ }
112120
113121-- | Make sure next output is delimited by one of the following.
114122data RequestedDelimiter
@@ -150,32 +158,55 @@ runR ::
150158 CommentStream ->
151159 -- | Annotations
152160 Anns ->
161+ -- | Use Record Dot Syntax
162+ Bool ->
153163 -- | Resulting rendition
154164 Text
155−runR (R m) sstream cstream anns =
165+runR (R m) sstream cstream anns recDot =
156166 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
157167 where
158− rc = RC
159− { rcIndent = 0,
160− rcLayout = MultiLine,
161− rcEnclosingSpans = [],
162− rcAnns = anns,
163− rcCanUseBraces = False
164− }
165− sc = SC
166− { scColumn = 0,
167− scBuilder = mempty,
168− scSpanStream = sstream,
169− scCommentStream = cstream,
170− scPendingComments = [],
171− scDirtyLine = False,
172− scRequestedDelimiter = VeryBeginning,
173− scLastCommentSpan = Nothing
174− }
168+ rc =
169+ RC
170+ { rcIndent = 0,
171+ rcLayout = MultiLine,
172+ rcEnclosingSpans = [],
173+ rcAnns = anns,
174+ rcCanUseBraces = False,
175+ rcUseRecDot = recDot
176+ }
177+ sc =
178+ SC
179+ { scColumn = 0,
180+ scIndent = 0,
181+ scBuilder = mempty,
182+ scSpanStream = sstream,
183+ scThisLineSpans = [],
184+ scCommentStream = cstream,
185+ scPendingComments = [],
186+ scRequestedDelimiter = VeryBeginning,
187+ scSpanMark = Nothing
188+ }
175189
176190----------------------------------------------------------------------------
177191-- Internal functions
178192
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+
179210-- | Output a fixed 'Text' fragment. The argument may not contain any line
180211-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
181212-- keywords and pipes @|@ in functional dependencies.
@@ -187,7 +218,15 @@ txt ::
187218 -- | 'Text' to output
188219 Text ->
189220 R ()
190−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
191230
192231-- | Output 'Outputable' fragment of AST. This can be used to output numeric
193232-- literals and similar. Everything that doesn't have inner structure but
@@ -196,48 +235,61 @@ atom ::
196235 Outputable a =>
197236 a ->
198237 R ()
199−atom = spit True False . T.pack . showOutputable
238+atom = spit Atom . T.pack . showOutputable
200239
201240-- | Low-level non-public helper to define 'txt' and 'atom'.
202241spit ::
203− -- | Should we mark the line as dirty?
204− Bool ->
205− -- | Used during outputting of pending comments?
206− Bool ->
242+ -- | Type of the thing to spit
243+ SpitType ->
207244 -- | 'Text' to output
208245 Text ->
209246 R ()
210−spit dirty printingComments txt' = do
247+spit _ "" = return ()
248+spit stype text = do
211249 requestedDel <- R (gets scRequestedDelimiter)
250+ pendingComments <- R (gets scPendingComments)
251+ when (stype == InterferingText && not (null pendingComments)) newline
212252 case requestedDel of
213253 RequestedNewline -> do
214254 R . modify $ \sc ->
215255 sc
216256 { scRequestedDelimiter = RequestedNothing
217257 }
218− if printingComments
219− then newlineRaw
220− else newline
258+ case stype of
259+ CommentPart -> newlineRaw
260+ _ -> newline
221261 _ -> return ()
222262 R $ do
223263 i <- asks rcIndent
224264 c <- gets scColumn
225− let spaces =
226− if c < i
227− then T.replicate (i - c) " "
228− else bool mempty " " (requestedDel == RequestedSpace)
229− 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)
230272 modify $ \sc ->
231273 sc
232274 { scBuilder = scBuilder sc <> fromText indentedTxt,
233275 scColumn = scColumn sc + T.length indentedTxt,
234− 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,
235287 scRequestedDelimiter = RequestedNothing,
236− scLastCommentSpan =
288+ scSpanMark =
237289 -- If there are pending comments, do not reset last comment
238290 -- location.
239− if printingComments || (not . null . scPendingComments) sc
240− then scLastCommentSpan sc
291+ if (stype == CommentPart) || (not . null . scPendingComments) sc
292+ then scSpanMark sc
241293 else Nothing
242294 }
243295
@@ -268,21 +320,22 @@ space = R . modify $ \sc ->
268320-- hard to output more than one blank newline in a row.
269321newline :: R ()
270322newline = do
323+ indent <- R (gets scIndent)
271324 cs <- reverse <$> R (gets scPendingComments)
272325 case cs of
273326 [] -> newlineRaw
274− ((position, _, _) : _) -> do
327+ ((position, _) : _) -> do
275328 case position of
276329 OnTheSameLine -> space
277330 OnNextLine -> newlineRaw
278− R . forM_ cs $ \(_, indent, txt') ->
331+ R . forM_ cs $ \(_, text) ->
279332 let modRC rc =
280333 rc
281334 { rcIndent = indent
282335 }
283336 R m = do
284− unless (T.null txt') $
285− spit False True txt'
337+ unless (T.null text) $
338+ spit CommentPart text
286339 newlineRaw
287340 in local modRC m
288341 R . modify $ \sc ->
@@ -303,7 +356,8 @@ newlineRaw = R . modify $ \sc ->
303356 VeryBeginning -> builderSoFar
304357 _ -> builderSoFar <> "\n",
305358 scColumn = 0,
306− scDirtyLine = False,
359+ scIndent = 0,
360+ scThisLineSpans = [],
307361 scRequestedDelimiter = case scRequestedDelimiter sc of
308362 AfterNewline -> RequestedNewline
309363 RequestedNewline -> RequestedNewline
@@ -311,10 +365,9 @@ newlineRaw = R . modify $ \sc ->
311365 _ -> AfterNewline
312366 }
313367
314−-- | Check if the current line is “dirty”, that is, there is something on it
315−-- that can have comments attached to it.
316−isLineDirty :: R Bool
317−isLineDirty = R (gets scDirtyLine)
368+-- | Return 'True' if we should print record dot syntax.
369+useRecordDot :: R Bool
370+useRecordDot = R (asks rcUseRecDot)
318371
319372-- | Increase indentation level by one indentation step for the inner
320373-- computation. 'inci' should be used when a part of code must be more
@@ -331,8 +384,7 @@ inci (R m) = R (local modRC m)
331384
332385-- | Set indentation level for the inner computation equal to current
333386-- column. This makes sure that the entire inner block is uniformly
334−-- \"shifted\" to the right. Only works (and makes sense) when enclosing
335−-- layout is multi-line.
387+-- \"shifted\" to the right.
336388sitcc :: R () -> R ()
337389sitcc (R m) = do
338390 requestedDel <- R (gets scRequestedDelimiter)
@@ -340,16 +392,9 @@ sitcc (R m) = do
340392 c <- R (gets scColumn)
341393 let modRC rc =
342394 rc
343− { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
395+ { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))
344396 }
345− vlayout (R m) . R $ do
346− modify $ \sc ->
347− sc
348− { scRequestedDelimiter = case requestedDel of
349− RequestedSpace -> RequestedNothing
350− other -> other
351− }
352− local modRC m
397+ R (local modRC m)
353398
354399-- | Set 'Layout' for internal computation.
355400enterLayout :: Layout -> R () -> R ()
@@ -390,11 +435,10 @@ registerPendingCommentLine ::
390435 -- | 'Text' to output
391436 Text ->
392437 R ()
393−registerPendingCommentLine position txt' = R $ do
394− i <- asks rcIndent
438+registerPendingCommentLine position text = R $ do
395439 modify $ \sc ->
396440 sc
397− { scPendingComments = (position, i, txt') : scPendingComments sc
441+ { scPendingComments = (position, text) : scPendingComments sc
398442 }
399443
400444-- | Drop elements that begin before or at the same place as given
@@ -453,6 +497,29 @@ withEnclosingSpan spn (R m) = R (local modRC m)
453497 { rcEnclosingSpans = spn : rcEnclosingSpans rc
454498 }
455499
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+
456523-- | Haddock string style.
457524data HaddockStyle
458525 = -- | @-- |@
@@ -465,20 +532,18 @@ data HaddockStyle
465532 Named String
466533
467534-- | Set span of last output comment.
468−setLastCommentSpan ::
469− -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
470− Maybe HaddockStyle ->
471− -- | Location of last printed comment
472− RealSrcSpan ->
535+setSpanMark ::
536+ -- | Span mark to set
537+ SpanMark ->
473538 R ()
474−setLastCommentSpan mhStyle spn = R . modify $ \sc ->
539+setSpanMark spnMark = R . modify $ \sc ->
475540 sc
476− { scLastCommentSpan = Just (mhStyle, spn)
541+ { scSpanMark = Just spnMark
477542 }
478543
479544-- | Get span of last output comment.
480−getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
481−getLastCommentSpan = R (gets scLastCommentSpan)
545+getSpanMark :: R (Maybe SpanMark)
546+getSpanMark = R (gets scSpanMark)
482547
483548----------------------------------------------------------------------------
484549-- Annotations
@@ -502,7 +567,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
502567
503568-- | Return 'True' if we can use braces in this context.
504569canUseBraces :: R Bool
505−canUseBraces = R $ asks rcCanUseBraces
570+canUseBraces = R (asks rcCanUseBraces)
506571
507572----------------------------------------------------------------------------
508573-- Constants
src/Ormolu/Printer/Meat/Common.hs+13−11
@@ -17,14 +17,12 @@ 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)
2423import OccName (OccName (..))
2524import Ormolu.Printer.Combinators
2625import Ormolu.Utils
27−import RdrName (RdrName (..))
2826
2927-- | Data and type family style.
3028data FamilyStyle
@@ -116,14 +114,14 @@ p_qualName mname occName = do
116114p_infixDefHelper ::
117115 -- | Whether to format in infix style
118116 Bool ->
119− -- | Indentation-bumping wrapper
120− (R () -> R ()) ->
117+ -- | Whether to bump indentation for arguments
118+ Bool ->
121119 -- | How to print the operator\/name
122120 R () ->
123121 -- | How to print the arguments
124122 [R ()] ->
125123 R ()
126−p_infixDefHelper isInfix inci' name args =
124+p_infixDefHelper isInfix indentArgs name args =
127125 case (isInfix, args) of
128126 (True, p0 : p1 : ps) -> do
129127 let parens' =
@@ -133,18 +131,18 @@ p_infixDefHelper isInfix inci' name args =
133131 parens' $ do
134132 p0
135133 breakpoint
136− inci $ sitcc $ do
134+ inci . sitcc $ do
137135 name
138136 space
139137 p1
140− unless (null ps) . inci' $ do
138+ unless (null ps) . inciIf indentArgs $ do
141139 breakpoint
142140 sitcc (sep breakpoint sitcc ps)
143141 (_, ps) -> do
144142 name
145143 unless (null ps) $ do
146144 breakpoint
147− inci' $ sitcc (sep breakpoint sitcc args)
145+ inciIf indentArgs $ sitcc (sep breakpoint sitcc args)
148146
149147-- | Print a Haddock.
150148p_hsDocString ::
@@ -156,7 +154,11 @@ p_hsDocString ::
156154 LHsDocString ->
157155 R ()
158156p_hsDocString hstyle needsNewline (L l str) = do
159− goesAfterComment <- isJust <$> getLastCommentSpan
157+ let isCommentSpan = \case
158+ HaddockSpan _ _ -> True
159+ CommentSpan _ -> True
160+ _ -> False
161+ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark
160162 -- Make sure the Haddock is separated by a newline from other comments.
161163 when goesAfterComment newline
162164 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do
@@ -175,8 +177,8 @@ p_hsDocString hstyle needsNewline (L l str) = do
175177 -- It's often the case that the comment itself doesn't have a span
176178 -- attached to it and instead its location can be obtained from
177179 -- nearest enclosing span.
178− getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))
179− RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
180+ getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)
181+ RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)
180182
181183-- | Print anchor of named doc section.
182184p_hsDocName :: String -> R ()
src/Ormolu/Printer/Meat/Declaration.hs+174−109
@@ -7,12 +7,12 @@
77-- | Rendering of declarations.
88module Ormolu.Printer.Meat.Declaration
99 ( p_hsDecls,
10− hasSeparatedDecls,
10+ p_hsDeclsRespectGrouping,
1111 )
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)
@@ -34,25 +34,57 @@ import Ormolu.Printer.Meat.Declaration.Value
3434import Ormolu.Printer.Meat.Declaration.Warning
3535import Ormolu.Printer.Meat.Type
3636import Ormolu.Utils
37−import RdrName (rdrNameOcc)
37+
38+data UserGrouping
39+ = -- | Always put newlines where we think they should be
40+ Disregard
41+ | -- | Respect user preferences regarding grouping
42+ Respect
43+ deriving (Eq, Show)
3844
3945p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
40−p_hsDecls style decls = sepSemi id $
41− -- Return a list of rendered declarations, adding a newline to separate
42− -- groups.
43− case groupDecls decls of
44− [] -> []
45− (x : xs) ->
46− NE.toList (renderGroup x)
47− ++ concatMap (NE.toList . separateGroup . renderGroup) xs
46+p_hsDecls = p_hsDecls' Disregard
47+
48+-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the
49+-- user omits newlines between declarations, we also omit them in most
50+-- cases, except when said declarations have associated Haddocks.
51+--
52+-- Does some normalization (compress subsequent newlines into a single one)
53+p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
54+p_hsDeclsRespectGrouping = p_hsDecls' Respect
55+
56+p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
57+p_hsDecls' grouping style decls =
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)
4864 where
49− renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style)
50− separateGroup (x :| xs) = (breakpoint' >> x) :| xs
65+ renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
66+ renderGroupWithPrev prev curr =
67+ -- We can omit a blank line when the user didn't add one, but we must
68+ -- ensure we always add blank lines around documented declarations
69+ case grouping of
70+ Disregard ->
71+ breakpoint : renderGroup curr
72+ Respect ->
73+ if separatedByBlankNE getLoc prev curr
74+ || isDocumented prev
75+ || isDocumented curr
76+ then breakpoint : renderGroup curr
77+ else renderGroup curr
78+
79+-- | Is a declaration group documented?
80+isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool
81+isDocumented = any (isHaddock . unLoc)
82+ where
83+ isHaddock DocNext = True
84+ isHaddock DocPrev = True
85+ isHaddock _ = False
5186
5287-- | Group relevant declarations together.
53−--
54−-- Add a declaration to a group iff it is relevant to either the first or
55−-- the last declaration of the group.
5688groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
5789groupDecls [] = []
5890groupDecls (l@(L _ DocNext) : xs) =
@@ -61,44 +93,40 @@ groupDecls (l@(L _ DocNext) : xs) =
6193 case groupDecls xs of
6294 [] -> [l :| []]
6395 (x : xs') -> (l <| x) : xs'
64−groupDecls (lhdr : xs) =
65− let -- Pick the first decl as the group header
66− hdr = unLoc lhdr
67− -- Zip rest of the decls with their previous decl
68− zipped = zip (lhdr : xs) xs
69− -- Pick decls from the tail if they are relevant to the group header
70− -- or the previous decl.
71− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->
72− let relevantToHdr = groupedDecls hdr cur
73− relevantToPrev = groupedDecls prev cur
74− in relevantToHdr || relevantToPrev
75− 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)
76103
77104p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
78105p_hsDecl style = \case
79− TyClD NoExt x -> p_tyClDecl style x
80− ValD NoExt x -> p_valDecl x
81− SigD NoExt x -> p_sigDecl x
82− InstD NoExt x -> p_instDecl style x
83− DerivD NoExt x -> p_derivDecl x
84− DefD NoExt x -> p_defaultDecl x
85− ForD NoExt x -> p_foreignDecl x
86− WarningD NoExt x -> p_warnDecls x
87− AnnD NoExt x -> p_annDecl x
88− RuleD NoExt x -> p_ruleDecls x
89− SpliceD NoExt x -> p_spliceDecl x
90− DocD NoExt docDecl ->
106+ TyClD NoExtField x -> p_tyClDecl style x
107+ ValD NoExtField x -> p_valDecl x
108+ SigD NoExtField x -> p_sigDecl x
109+ InstD NoExtField x -> p_instDecl style x
110+ DerivD NoExtField x -> p_derivDecl x
111+ DefD NoExtField x -> p_defaultDecl x
112+ ForD NoExtField x -> p_foreignDecl x
113+ WarningD NoExtField x -> p_warnDecls x
114+ AnnD NoExtField x -> p_annDecl x
115+ RuleD NoExtField x -> p_ruleDecls x
116+ SpliceD NoExtField x -> p_spliceDecl x
117+ DocD NoExtField docDecl ->
91118 case docDecl of
92119 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
93120 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
94121 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
95122 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
96− RoleAnnotD NoExt x -> p_roleAnnot x
97− XHsDecl _ -> notImplemented "XHsDecl"
123+ RoleAnnotD NoExtField x -> p_roleAnnot x
124+ KindSigD NoExtField s -> p_standaloneKindSig s
125+ XHsDecl x -> noExtCon x
98126
99127p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
100128p_tyClDecl style = \case
101− FamDecl NoExt x -> p_famDecl style x
129+ FamDecl NoExtField x -> p_famDecl style x
102130 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
103131 DataDecl {..} ->
104132 p_dataDecl
@@ -119,39 +147,65 @@ p_tyClDecl style = \case
119147 tcdATs
120148 tcdATDefs
121149 tcdDocs
122− XTyClDecl {} -> notImplemented "XTyClDecl"
150+ XTyClDecl x -> noExtCon x
123151
124152p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
125153p_instDecl style = \case
126− ClsInstD NoExt x -> p_clsInstDecl x
127− TyFamInstD NoExt x -> p_tyFamInstDecl style x
128− DataFamInstD NoExt x -> p_dataFamInstDecl style x
129− XInstDecl _ -> notImplemented "XInstDecl"
154+ ClsInstD NoExtField x -> p_clsInstDecl x
155+ TyFamInstD NoExtField x -> p_tyFamInstDecl style x
156+ DataFamInstD NoExtField x -> p_dataFamInstDecl style x
157+ XInstDecl x -> noExtCon x
130158
131159p_derivDecl :: DerivDecl GhcPs -> R ()
132160p_derivDecl = \case
133− d@DerivDecl {..} -> p_standaloneDerivDecl d
134− XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
161+ d@DerivDecl {} -> p_standaloneDerivDecl d
162+ XDerivDecl x -> noExtCon x
135163
136164-- | Determine if these declarations should be grouped together.
137165groupedDecls ::
138− HsDecl GhcPs ->
139− HsDecl GhcPs ->
166+ LHsDecl GhcPs ->
167+ LHsDecl GhcPs ->
168+ Bool
169+groupedDecls (L l_x x') (L l_y y') =
170+ case (x', y') of
171+ (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'
172+ (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'
173+ (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'
174+ (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'
175+ (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'
176+ (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
177+ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns
178+ (DataDeclaration n, x)
179+ | Just ns <- isPragma x ->
180+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns
181+ (x, y)
182+ | Just ns <- isPragma x,
183+ Just ns' <- isPragma y ->
184+ ns `intersects` ns'
185+ (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'
186+ (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'
187+ (PatternSignature ns, Pattern n) -> n `elem` ns
188+ (KindSignature n, DataDeclaration n') -> n == n'
189+ (KindSignature n, ClassDeclaration n') -> n == n'
190+ (KindSignature n, FamilyDeclaration n') -> n == n'
191+ -- Special case for TH splices, we look at locations
192+ (Splice, Splice) -> not (separatedByBlank id l_x l_y)
193+ -- This looks only at Haddocks, normal comments are handled elsewhere
194+ (DocNext, _) -> True
195+ (_, DocPrev) -> True
196+ _ -> False
197+
198+-- | Detect declaration series that should not have blanks between them.
199+declSeries ::
200+ LHsDecl GhcPs ->
201+ LHsDecl GhcPs ->
140202 Bool
141−groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'
142−groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'
143−groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'
144−groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns
145−groupedDecls (DataDeclaration n) x
146− | Just ns <- isPragma x =
147− let f = occNameFS . rdrNameOcc in f n `elem` map f ns
148−groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'
149−groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'
150−groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'
151−groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns
152−groupedDecls DocNext _ = True
153−groupedDecls _ DocPrev = True
154−groupedDecls _ _ = False
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
155209
156210intersects :: Ord a => [a] -> [a] -> Bool
157211intersects a b = go (sort a) (sort b)
@@ -164,13 +218,6 @@ intersects a b = go (sort a) (sort b)
164218 | x > y = go (x : xs) ys
165219 | otherwise = True
166220
167−-- | Checks if given list of declarations contain a pair which should
168−-- be separated by a blank line.
169−hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
170−hasSeparatedDecls xs = case groupDecls xs of
171− _ : _ : _ -> True
172− _ -> False
173−
174221isPragma ::
175222 HsDecl GhcPs ->
176223 Maybe [RdrName]
@@ -183,6 +230,11 @@ isPragma = \case
183230 WarningPragma n -> Just n
184231 _ -> Nothing
185232
233+-- Declarations that do not refer to names
234+
235+pattern Splice :: HsDecl GhcPs
236+pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)
237+
186238-- Declarations referring to a single name
187239
188240pattern
@@ -192,71 +244,84 @@ pattern
192244 AnnTypePragma,
193245 AnnValuePragma,
194246 Pattern,
195− DataDeclaration ::
247+ DataDeclaration,
248+ ClassDeclaration,
249+ KindSignature,
250+ FamilyDeclaration ::
196251 RdrName -> HsDecl GhcPs
197−pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
198−pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)
199−pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)
200−pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)
201−pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)
202−pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))
203−pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)
252+pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)
253+pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)
254+pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)
255+pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)
256+pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)
257+pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))
258+pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _)
259+pattern ClassDeclaration n <- TyClD NoExtField (ClassDecl NoExtField _ (L _ n) _ _ _ _ _ _ _ _)
260+pattern KindSignature n <- KindSigD NoExtField (StandaloneKindSig NoExtField (L _ n) _)
261+pattern FamilyDeclaration n <- TyClD NoExtField (FamDecl NoExtField (FamilyDecl NoExtField _ (L _ n) _ _ _ _))
204262
205263-- Declarations which can refer to multiple names
206264
207265pattern
208266 TypeSignature,
267+ DefaultSignature,
209268 FunctionBody,
210269 PatternSignature,
211270 WarningPragma ::
212271 [RdrName] -> HsDecl GhcPs
213272pattern TypeSignature n <- (sigRdrNames -> Just n)
273+pattern DefaultSignature n <- (defSigRdrNames -> Just n)
214274pattern FunctionBody n <- (funRdrNames -> Just n)
215275pattern PatternSignature n <- (patSigRdrNames -> Just n)
216276pattern WarningPragma n <- (warnSigRdrNames -> Just n)
217277
218278pattern DocNext, DocPrev :: HsDecl GhcPs
219−pattern DocNext <- (DocD NoExt (DocCommentNext _))
220−pattern DocPrev <- (DocD NoExt (DocCommentPrev _))
279+pattern DocNext <- (DocD NoExtField (DocCommentNext _))
280+pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))
221281
222282sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
223−sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns
224−sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns
225−sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
283+sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns
284+sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns
285+sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
226286sigRdrNames _ = Nothing
227287
288+defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
289+defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns
290+defSigRdrNames _ = Nothing
291+
228292funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
229−funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
230−funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n
293+funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]
294+funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n
231295funRdrNames _ = Nothing
232296
233297patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
234−patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
298+patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
235299patSigRdrNames _ = Nothing
236300
237301warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
238−warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
239− L _ (Warning NoExt ns _) -> map unLoc ns
240− L _ (XWarnDecl NoExt) -> []
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
241306warnSigRdrNames _ = Nothing
242307
243308patBindNames :: Pat GhcPs -> [RdrName]
244−patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps
245−patBindNames (VarPat NoExt (L _ n)) = [n]
246−patBindNames (WildPat NoExt) = []
247−patBindNames (LazyPat NoExt p) = patBindNames p
248−patBindNames (BangPat NoExt p) = patBindNames p
249−patBindNames (ParPat NoExt p) = patBindNames p
250−patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
251−patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p
252−patBindNames (SumPat NoExt p _ _) = patBindNames p
253−patBindNames (ViewPat NoExt _ p) = patBindNames p
254−patBindNames (SplicePat NoExt _) = []
255−patBindNames (LitPat NoExt _) = []
256−patBindNames (SigPat _ p _) = patBindNames p
257−patBindNames (NPat NoExt _ _ _) = []
258−patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]
309+patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps
310+patBindNames (VarPat NoExtField (L _ n)) = [n]
311+patBindNames (WildPat NoExtField) = []
312+patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p
313+patBindNames (BangPat NoExtField (L _ p)) = patBindNames p
314+patBindNames (ParPat NoExtField (L _ p)) = patBindNames p
315+patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps
316+patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p
317+patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p
318+patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p
319+patBindNames (SplicePat NoExtField _) = []
320+patBindNames (LitPat NoExtField _) = []
321+patBindNames (SigPat _ (L _ p) _) = patBindNames p
322+patBindNames (NPat NoExtField _ _ _) = []
323+patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]
259324patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
260325patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
261−patBindNames (CoPat NoExt _ p _) = patBindNames p
262−patBindNames (XPat p) = patBindNames (unLoc p)
326+patBindNames (CoPat NoExtField _ p _) = patBindNames p
327+patBindNames (XPat x) = noExtCon x
src/Ormolu/Printer/Meat/Declaration.hs-boot+2−3
@@ -1,6 +1,6 @@
11module Ormolu.Printer.Meat.Declaration
22 ( p_hsDecls,
3− hasSeparatedDecls,
3+ p_hsDeclsRespectGrouping,
44 )
55where
66
@@ -9,5 +9,4 @@ import Ormolu.Printer.Combinators
99import Ormolu.Printer.Meat.Common
1010
1111p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12−
13−hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
12+p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
src/Ormolu/Printer/Meat/Declaration/Annotation.hs+2−3
@@ -10,15 +10,14 @@ import GHC
1010import Ormolu.Printer.Combinators
1111import Ormolu.Printer.Meat.Common
1212import Ormolu.Printer.Meat.Declaration.Value
13−import Ormolu.Utils
1413
1514p_annDecl :: AnnDecl GhcPs -> R ()
1615p_annDecl = \case
17− HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do
16+ HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do
1817 p_annProv annProv
1918 breakpoint
2019 located expr p_hsExpr
21− XAnnDecl {} -> notImplemented "XAnnDecl"
20+ XAnnDecl x -> noExtCon x
2221
2322p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
2423p_annProv = \case
src/Ormolu/Printer/Meat/Declaration/Class.hs+22−33
@@ -18,8 +18,6 @@ import Ormolu.Printer.Combinators
1818import Ormolu.Printer.Meat.Common
1919import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2020import Ormolu.Printer.Meat.Type
21−import Ormolu.Utils
22−import RdrName (RdrName (..))
2321
2422p_classDecl ::
2523 LHsContext GhcPs ->
@@ -30,7 +28,7 @@ p_classDecl ::
3028 [LSig GhcPs] ->
3129 LHsBinds GhcPs ->
3230 [LFamilyDecl GhcPs] ->
33− [LTyFamDefltEqn GhcPs] ->
31+ [LTyFamDefltDecl GhcPs] ->
3432 [LDocDecl] ->
3533 R ()
3634p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do
@@ -38,6 +36,20 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
3836 signatureSpans = getLoc name : variableSpans
3937 dependencySpans = getLoc <$> fdeps
4038 combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)
39+ -- GHC's AST does not necessarily store each kind of element in source
40+ -- location order. This happens because different declarations are stored
41+ -- in different lists. Consequently, to get all the declarations in proper
42+ -- order, they need to be manually sorted.
43+ sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs
44+ vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs
45+ tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats
46+ docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs
47+ tyFamDefs =
48+ ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
49+ )
50+ <$> catdefs
51+ allDecls =
52+ snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)
4153 txt "class"
4254 switchLayout combinedSpans $ do
4355 breakpoint
@@ -46,33 +58,17 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d
4658 switchLayout signatureSpans $
4759 p_infixDefHelper
4860 (isInfix fixity)
49− inci
61+ True
5062 (p_rdrName name)
5163 (located' p_hsTyVarBndr <$> hsq_explicit)
5264 inci (p_classFundeps fdeps)
53− -- GHC's AST does not necessarily store each kind of element in source
54− -- location order. This happens because different declarations are stored
55− -- in different lists. Consequently, to get all the declarations in proper
56− -- order, they need to be manually sorted.
57− let sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs
58− vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs
59− tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats
60− docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
61− tyFamDefs =
62− ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
63− )
64− <$> catdefs
65− allDecls =
66− snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)
65+ unless (null allDecls) $ do
66+ breakpoint
67+ txt "where"
6768 unless (null allDecls) $ do
68− space
69− txt "where"
7069 breakpoint -- Ensure whitespace is added after where clause.
71− -- Add newline before first declaration if the body contains separate
72− -- declarations.
73− when (hasSeparatedDecls allDecls) breakpoint'
74− inci (p_hsDecls Associated allDecls)
75−p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"
70+ inci (p_hsDeclsRespectGrouping Associated allDecls)
71+p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c
7672
7773p_classContext :: LHsContext GhcPs -> R ()
7874p_classContext ctx = unless (null (unLoc ctx)) $ do
@@ -86,7 +82,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do
8682 breakpoint
8783 txt "|"
8884 space
89− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps
85+ inci $ sep commaDel (sitcc . located' p_funDep) fdeps
9086
9187p_funDep :: FunDep (Located RdrName) -> R ()
9288p_funDep (before, after) = do
@@ -99,13 +95,6 @@ p_funDep (before, after) = do
9995----------------------------------------------------------------------------
10096-- Helpers
10197
102−defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
103−defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}
104− where
105− eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}
106− tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}
107−defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"
108−
10998isInfix :: LexicalFixity -> Bool
11099isInfix = \case
111100 Infix -> True
src/Ormolu/Printer/Meat/Declaration/Data.hs+68−43
@@ -15,8 +15,6 @@ import Ormolu.Printer.Combinators
1515import Ormolu.Printer.Meat.Common
1616import Ormolu.Printer.Meat.Type
1717import Ormolu.Utils
18−import RdrName (RdrName (..))
19−import SrcLoc (Located)
2018
2119p_dataDecl ::
2220 -- | Whether to format as data family
@@ -37,12 +35,13 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
3735 txt $ case style of
3836 Associated -> mempty
3937 Free -> " instance"
40− switchLayout (getLoc name : fmap getLoc tpats) $ do
38+ let constructorSpans = getLoc name : fmap getLoc tpats
39+ switchLayout constructorSpans $ do
4140 breakpoint
4241 inci $
4342 p_infixDefHelper
4443 (isInfix fixity)
45− inci
44+ True
4645 (p_rdrName name)
4746 (located' p_hsType <$> tpats)
4847 case dd_kindSig of
@@ -55,29 +54,42 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
5554 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons
5655 unless (null dd_cons) $
5756 if gadt
58− then do
59− space
60− txt "where"
61− breakpoint
62− inci $ sepSemi (located' p_conDecl) dd_cons
63− else switchLayout (getLoc name : (getLoc <$> dd_cons))
64− $ inci
65− $ do
57+ then inci $ do
58+ switchLayout constructorSpans $ do
6659 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
60+ txt "where"
61+ breakpoint
62+ sepSemi (located' (p_conDecl False)) dd_cons
63+ else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do
64+ let singleConstRec = isSingleConstRec dd_cons
65+ if singleConstRec
66+ then space
67+ else
68+ if hasHaddocks dd_cons
69+ then newline
70+ else breakpoint
71+ equals
72+ space
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
77−p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"
86+p_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)
@@ -104,7 +115,7 @@ p_conDecl = \case
104115 else breakpoint
105116 interArgBreak
106117 when (unLoc con_forall) $ do
107− p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)
118+ p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)
108119 interArgBreak
109120 forM_ con_mb_cxt p_lhsContext
110121 case con_args of
@@ -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
135− p_forallBndrs p_hsTyVarBndr con_ex_tvs
147+ 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
@@ -151,7 +163,7 @@ p_conDecl = \case
151163 p_rdrName con_name
152164 space
153165 located y p_hsType
154− XConDecl NoExt -> notImplemented "XConDecl"
166+ XConDecl x -> noExtCon x
155167
156168conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
157169conArgsSpans = \case
@@ -165,7 +177,7 @@ conArgsSpans = \case
165177conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
166178conTyVarsSpans = \case
167179 HsQTvs {..} -> getLoc <$> hsq_explicit
168− XLHsQTyVars NoExt -> []
180+ XLHsQTyVars x -> noExtCon x
169181
170182p_lhsContext ::
171183 LHsContext GhcPs ->
@@ -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
@@ -223,9 +235,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
223235 txt "via"
224236 space
225237 located hsib_body p_hsType
226− ViaStrategy (XHsImplicitBndrs NoExt) ->
227− notImplemented "XHsImplicitBndrs"
228−p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
238+ ViaStrategy (XHsImplicitBndrs x) ->
239+ noExtCon x
240+p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
229241
230242----------------------------------------------------------------------------
231243-- Helpers
@@ -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+4−5
@@ -9,13 +9,12 @@ where
99import GHC
1010import Ormolu.Printer.Combinators
1111import Ormolu.Printer.Meat.Type
12−import Ormolu.Utils
1312
1413p_defaultDecl :: DefaultDecl GhcPs -> R ()
1514p_defaultDecl = \case
16− DefaultDecl NoExt ts -> do
15+ DefaultDecl NoExtField ts -> do
1716 txt "default"
1817 breakpoint
19− inci . parens N . sitcc $
20− sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
21− XDefaultDecl {} -> notImplemented "XDefaultDecl"
18+ inci . parens N $
19+ sep commaDel (sitcc . located' p_hsType) ts
20+ XDefaultDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Foreign.hs+2−3
@@ -15,7 +15,6 @@ import GHC
1515import Ormolu.Printer.Combinators
1616import Ormolu.Printer.Meat.Common
1717import Ormolu.Printer.Meat.Declaration.Signature
18−import Ormolu.Utils
1918
2019p_foreignDecl :: ForeignDecl GhcPs -> R ()
2120p_foreignDecl = \case
@@ -25,7 +24,7 @@ p_foreignDecl = \case
2524 fd@ForeignExport {fd_fe} -> do
2625 p_foreignExport fd_fe
2726 p_foreignTypeSig fd
28− XForeignDecl {} -> notImplemented "XForeignDecl"
27+ XForeignDecl x -> noExtCon x
2928
3029-- | Printer for the last part of an import\/export, which is function name
3130-- and type signature.
@@ -39,7 +38,7 @@ p_foreignTypeSig fd = do
3938 ]
4039 $ do
4140 p_rdrName (fd_name fd)
42− p_typeAscription (HsWC NoExt (fd_sig_ty fd))
41+ p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
4342
4443-- | Printer for 'ForeignImport'.
4544--
src/Ormolu/Printer/Meat/Declaration/Instance.hs+13−20
@@ -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
@@ -56,8 +54,8 @@ p_standaloneDerivDecl DerivDecl {..} = do
5654 inci (located hsib_body p_hsType)
5755 breakpoint
5856 instTypes True
59− ViaStrategy (XHsImplicitBndrs NoExt) ->
60− notImplemented "XHsImplicitBndrs"
57+ ViaStrategy (XHsImplicitBndrs x) ->
58+ noExtCon x
6159p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
6260
6361p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
@@ -70,14 +68,14 @@ p_clsInstDecl = \case
7068 -- location order. This happens because different declarations are stored in
7169 -- different lists. Consequently, to get all the declarations in proper
7270 -- order, they need to be manually sorted.
73− let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs
74− vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
71+ let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs
72+ vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds
7573 tyFamInsts =
76− ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
74+ ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
7775 )
7876 <$> cid_tyfam_insts
7977 dataFamInsts =
80− ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
78+ ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)
8179 )
8280 <$> cid_datafam_insts
8381 allDecls =
@@ -90,17 +88,12 @@ 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− -- Add newline before first declaration if the body contains separate
99− -- declarations
100− when (hasSeparatedDecls allDecls) breakpoint'
101− dontUseBraces $ p_hsDecls Associated allDecls
102− XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"
103− XClsInstDecl NoExt -> notImplemented "XClsInstDecl"
91+ unless (null allDecls) . inci $ do
92+ -- Ensure whitespace is added after where clause.
93+ breakpoint
94+ dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
95+ XHsImplicitBndrs x -> noExtCon x
96+ XClsInstDecl x -> noExtCon x
10497
10598p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
10699p_tyFamInstDecl style = \case
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+2−5
@@ -12,14 +12,11 @@ import CoAxiom
1212import GHC
1313import Ormolu.Printer.Combinators
1414import Ormolu.Printer.Meat.Common
15−import Ormolu.Utils
16−import RdrName (RdrName (..))
17−import SrcLoc (Located)
1815
1916p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
2017p_roleAnnot = \case
21− RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns
22− XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"
18+ RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns
19+ XRoleAnnotDecl x -> noExtCon x
2320
2421p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
2522p_roleAnnot' l_name anns = do
src/Ormolu/Printer/Meat/Declaration/Rule.hs+12−13
@@ -14,18 +14,17 @@ import Ormolu.Printer.Meat.Common
1414import Ormolu.Printer.Meat.Declaration.Signature
1515import Ormolu.Printer.Meat.Declaration.Value
1616import Ormolu.Printer.Meat.Type
17−import Ormolu.Utils
1817
1918p_ruleDecls :: RuleDecls GhcPs -> R ()
2019p_ruleDecls = \case
21− HsRules NoExt _ xs ->
22− pragma "RULES" . sitcc $
20+ HsRules NoExtField _ xs ->
21+ pragma "RULES" $
2322 sep breakpoint (sitcc . located' p_ruleDecl) xs
24− XRuleDecls NoExt -> notImplemented "XRuleDecls"
23+ XRuleDecls x -> noExtCon x
2524
2625p_ruleDecl :: RuleDecl GhcPs -> R ()
2726p_ruleDecl = \case
28− HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do
27+ HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do
2928 located ruleName p_ruleName
3029 space
3130 p_activation activation
@@ -33,30 +32,30 @@ p_ruleDecl = \case
3332 case tyvars of
3433 Nothing -> return ()
3534 Just xs -> do
36− p_forallBndrs p_hsTyVarBndr xs
35+ p_forallBndrs ForallInvis p_hsTyVarBndr xs
3736 space
3837 -- It appears that there is no way to tell if there was an empty forall
3938 -- in the input or no forall at all. We do not want to add redundant
4039 -- foralls, so let's just skip the empty ones.
4140 unless (null ruleBndrs) $
42− p_forallBndrs p_ruleBndr ruleBndrs
41+ p_forallBndrs ForallInvis p_ruleBndr ruleBndrs
4342 breakpoint
4443 inci $ do
4544 located lhs p_hsExpr
4645 space
47− txt "="
46+ equals
4847 inci $ do
4948 breakpoint
5049 located rhs p_hsExpr
51− XRuleDecl NoExt -> notImplemented "XRuleDecl"
50+ XRuleDecl x -> noExtCon x
5251
5352p_ruleName :: (SourceText, RuleName) -> R ()
54−p_ruleName (_, name) = atom $ HsString NoSourceText name
53+p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)
5554
5655p_ruleBndr :: RuleBndr GhcPs -> R ()
5756p_ruleBndr = \case
58− RuleBndr NoExt x -> p_rdrName x
59− RuleBndrSig NoExt x hswc -> parens N $ do
57+ RuleBndr NoExtField x -> p_rdrName x
58+ RuleBndrSig NoExtField x hswc -> parens N $ do
6059 p_rdrName x
6160 p_typeAscription hswc
62− XRuleBndr NoExt -> notImplemented "XRuleBndr"
61+ XRuleBndr x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Signature.hs+49−33
@@ -7,13 +7,13 @@ module Ormolu.Printer.Meat.Declaration.Signature
77 ( p_sigDecl,
88 p_typeAscription,
99 p_activation,
10+ p_standaloneKindSig,
1011 )
1112where
1213
1314import BasicTypes
1415import BooleanFormula
1516import Control.Monad
16−import Data.Bool (bool)
1717import GHC
1818import Ormolu.Printer.Combinators
1919import Ormolu.Printer.Meat.Common
@@ -22,16 +22,16 @@ import Ormolu.Utils
2222
2323p_sigDecl :: Sig GhcPs -> R ()
2424p_sigDecl = \case
25− TypeSig NoExt names hswc -> p_typeSig True names hswc
26− PatSynSig NoExt names hsib -> p_patSynSig names hsib
27− ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib
28− FixSig NoExt sig -> p_fixSig sig
29− InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma
30− SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma
31− SpecInstSig NoExt _ hsib -> p_specInstSig hsib
32− MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula
33− CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty
34− SCCFunSig NoExt _ name literal -> p_sccSig name literal
25+ TypeSig NoExtField names hswc -> p_typeSig True names hswc
26+ PatSynSig NoExtField names hsib -> p_patSynSig names hsib
27+ ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib
28+ FixSig NoExtField sig -> p_fixSig sig
29+ InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma
30+ SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma
31+ SpecInstSig NoExtField _ hsib -> p_specInstSig hsib
32+ MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula
33+ CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty
34+ SCCFunSig NoExtField _ name literal -> p_sccSig name literal
3535 _ -> notImplemented "certain types of signature declarations"
3636
3737p_typeSig ::
@@ -47,25 +47,23 @@ p_typeSig indentTail (n : ns) hswc = do
4747 p_rdrName n
4848 if null ns
4949 then p_typeAscription hswc
50− else bool id inci indentTail $ do
51− comma
52− breakpoint
53− sep (comma >> breakpoint) p_rdrName ns
50+ else inciIf indentTail $ do
51+ commaDel
52+ sep commaDel p_rdrName ns
5453 p_typeAscription hswc
5554
5655p_typeAscription ::
5756 LHsSigWcType GhcPs ->
5857 R ()
59−p_typeAscription HsWC {..} = do
58+p_typeAscription HsWC {..} = inci $ do
6059 space
61− inci $ do
62− txt "::"
63− let t = hsib_body hswc_body
64− if hasDocStrings (unLoc t)
65− then newline
66− else breakpoint
67− located t p_hsType
68−p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"
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
66+p_typeAscription (XHsWildCardBndrs x) = noExtCon x
6967
7068p_patSynSig ::
7169 [Located RdrName] ->
@@ -73,7 +71,11 @@ p_patSynSig ::
7371 R ()
7472p_patSynSig names hsib = do
7573 txt "pattern"
76− let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
74+ let body =
75+ p_typeSig
76+ False
77+ names
78+ HsWC {hswc_ext = NoExtField, hswc_body = hsib}
7779 if length names > 1
7880 then breakpoint >> inci body
7981 else space >> body
@@ -88,13 +90,13 @@ p_classOpSig ::
8890 R ()
8991p_classOpSig def names hsib = do
9092 when def (txt "default" >> space)
91− p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
93+ p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
9294
9395p_fixSig ::
9496 FixitySig GhcPs ->
9597 R ()
9698p_fixSig = \case
97− FixitySig NoExt names (Fixity _ n dir) -> do
99+ FixitySig NoExtField names (Fixity _ n dir) -> do
98100 txt $ case dir of
99101 InfixL -> "infixl"
100102 InfixR -> "infixr"
@@ -102,8 +104,8 @@ p_fixSig = \case
102104 space
103105 atom n
104106 space
105− sitcc $ sep (comma >> breakpoint) p_rdrName names
106− XFixitySig NoExt -> notImplemented "XFixitySig"
107+ sitcc $ sep commaDel p_rdrName names
108+ XFixitySig x -> noExtCon x
107109
108110p_inlineSig ::
109111 -- | Name
@@ -141,7 +143,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do
141143 space
142144 txt "::"
143145 breakpoint
144− inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts
146+ inci $ sep commaDel (located' p_hsType . hsib_body) ts
145147
146148p_inlineSpec :: InlineSpec -> R ()
147149p_inlineSpec = \case
@@ -185,13 +187,13 @@ p_booleanFormula = \case
185187 And xs ->
186188 sitcc $
187189 sep
188− (comma >> breakpoint)
190+ commaDel
189191 (located' p_booleanFormula)
190192 xs
191193 Or xs ->
192194 sitcc $
193195 sep
194− (breakpoint >> txt "| ")
196+ (breakpoint >> txt "|" >> space)
195197 (located' p_booleanFormula)
196198 xs
197199 Parens l -> located l (parens N . p_booleanFormula)
@@ -205,7 +207,7 @@ p_completeSig ::
205207p_completeSig cs' mty =
206208 located cs' $ \cs ->
207209 pragma "COMPLETE" . inci $ do
208− sitcc $ sep (comma >> breakpoint) p_rdrName cs
210+ sep commaDel p_rdrName cs
209211 forM_ mty $ \ty -> do
210212 space
211213 txt "::"
@@ -218,3 +220,17 @@ p_sccSig loc literal = pragma "SCC" . inci $ do
218220 forM_ literal $ \x -> do
219221 breakpoint
220222 atom x
223+
224+p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
225+p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do
226+ txt "type"
227+ inci $ do
228+ space
229+ p_rdrName name
230+ space
231+ txt "::"
232+ breakpoint
233+ case bndrs of
234+ HsIB NoExtField sig -> located sig p_hsType
235+ XHsImplicitBndrs x -> noExtCon x
236+p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c
src/Ormolu/Printer/Meat/Declaration/Splice.hs+2−3
@@ -8,9 +8,8 @@ where
88import GHC
99import Ormolu.Printer.Combinators
1010import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
11−import Ormolu.Utils
1211
1312p_spliceDecl :: SpliceDecl GhcPs -> R ()
1413p_spliceDecl = \case
15− SpliceDecl NoExt splice _explicit -> located splice p_hsSplice
16− XSpliceDecl {} -> notImplemented "XSpliceDecl"
14+ SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice
15+ XSpliceDecl x -> noExtCon x
src/Ormolu/Printer/Meat/Declaration/Type.hs+6−7
@@ -11,9 +11,6 @@ import GHC
1111import Ormolu.Printer.Combinators
1212import Ormolu.Printer.Meat.Common
1313import Ormolu.Printer.Meat.Type
14−import Ormolu.Utils (notImplemented)
15−import RdrName (RdrName (..))
16−import SrcLoc (Located)
1714
1815p_synDecl ::
1916 -- | Type constructor
@@ -31,11 +28,13 @@ p_synDecl name fixity HsQTvs {..} t = do
3128 switchLayout (getLoc name : map getLoc hsq_explicit) $
3229 p_infixDefHelper
3330 (case fixity of Infix -> True; _ -> False)
34− inci
31+ True
3532 (p_rdrName name)
3633 (map (located' p_hsTyVarBndr) hsq_explicit)
3734 space
38− txt "="
39− breakpoint
35+ equals
36+ if hasDocStrings (unLoc t)
37+ then newline
38+ else breakpoint
4039 inci (located t p_hsType)
41−p_synDecl _ _ XLHsQTyVars {} _ = notImplemented "XLHsQTyVars"
40+p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+22−23
@@ -9,15 +9,13 @@ module Ormolu.Printer.Meat.Declaration.TypeFamily
99 )
1010where
1111
12−import BasicTypes (LexicalFixity (..))
1312import Control.Monad
14−import Data.Maybe (isJust, isNothing)
13+import Data.Maybe (isNothing)
1514import GHC
1615import Ormolu.Printer.Combinators
1716import Ormolu.Printer.Meat.Common
1817import Ormolu.Printer.Meat.Type
1918import Ormolu.Utils
20−import SrcLoc (GenLocated (..), Located)
2119
2220p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
2321p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
@@ -33,20 +31,21 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
3331 switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $
3432 p_infixDefHelper
3533 (isInfix fdFixity)
36− inci
34+ True
3735 (p_rdrName fdLName)
3836 (located' p_hsTyVarBndr <$> hsq_explicit)
39− let rsig = p_familyResultSigL fdResultSig
40− unless (isNothing rsig && isNothing fdInjectivityAnn) space
37+ let resultSig = p_familyResultSigL fdResultSig
38+ unless (isNothing resultSig && isNothing fdInjectivityAnn) space
4139 inci $ do
42− sequence_ rsig
43− when (isJust rsig && isJust fdInjectivityAnn) breakpoint
40+ sequence_ resultSig
41+ space
4442 forM_ fdInjectivityAnn (located' p_injectivityAnn)
4543 case mmeqs of
4644 Nothing -> return ()
4745 Just meqs -> do
48− space
49− txt "where"
46+ inci $ do
47+ breakpoint
48+ txt "where"
5049 case meqs of
5150 Nothing -> do
5251 space
@@ -56,7 +55,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
5655 sep newline (located' (inci . p_tyFamInstEqn)) eqs
5756p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
5857 notImplemented "XLHsQTyVars"
59−p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
58+p_famDecl _ (XFamilyDecl x) = noExtCon x
6059
6160p_familyResultSigL ::
6261 Located (FamilyResultSig GhcPs) ->
@@ -64,17 +63,17 @@ p_familyResultSigL ::
6463p_familyResultSigL l =
6564 case l of
6665 L _ a -> case a of
67− NoSig NoExt -> Nothing
68− KindSig NoExt k -> Just $ do
66+ NoSig NoExtField -> Nothing
67+ KindSig NoExtField k -> Just $ do
6968 txt "::"
7069 breakpoint
7170 located k p_hsType
72− TyVarSig NoExt bndr -> Just $ do
73− txt "="
71+ TyVarSig NoExtField bndr -> Just $ do
72+ equals
7473 breakpoint
7574 located bndr p_hsTyVarBndr
76− XFamilyResultSig NoExt ->
77− notImplemented "XFamilyResultSig"
75+ XFamilyResultSig x ->
76+ noExtCon x
7877
7978p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
8079p_injectivityAnn (InjectivityAnn a bs) = do
@@ -91,22 +90,22 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
9190 case feqn_bndrs of
9291 Nothing -> return ()
9392 Just bndrs -> do
94− p_forallBndrs p_hsTyVarBndr bndrs
93+ p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
9594 breakpoint
96− (if null feqn_bndrs then id else inci) $ do
95+ inciIf (not $ null feqn_bndrs) $ do
9796 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
9897 switchLayout famLhsSpn $
9998 p_infixDefHelper
10099 (isInfix feqn_fixity)
101− inci
100+ True
102101 (p_rdrName feqn_tycon)
103102 (located' p_hsType . typeArgToType <$> feqn_pats)
104103 space
105− txt "="
104+ equals
106105 breakpoint
107106 inci (located feqn_rhs p_hsType)
108−p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn"
109−p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
107+p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
108+p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
110109
111110----------------------------------------------------------------------------
112111-- Helpers
src/Ormolu/Printer/Meat/Declaration/Value.hs+404−344
@@ -1,6 +1,8 @@
11{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
23{-# LANGUAGE OverloadedStrings #-}
34{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE TypeApplications #-}
46
57module Ormolu.Printer.Meat.Declaration.Value
68 ( p_valDecl,
@@ -20,21 +22,20 @@ import Data.Char (isPunctuation, isSymbol)
2022import Data.Data hiding (Infix, Prefix)
2123import Data.Functor ((<&>))
2224import Data.List (intersperse, sortOn)
23−import Data.List.NonEmpty ((<|), NonEmpty ((:|)))
25+import Data.List.NonEmpty (NonEmpty (..), (<|))
2426import qualified Data.List.NonEmpty as NE
2527import Data.Text (Text)
2628import qualified Data.Text as Text
2729import GHC
28−import OccName (mkVarOcc)
30+import OccName (occNameString)
2931import Ormolu.Printer.Combinators
32+import Ormolu.Printer.Internal
3033import Ormolu.Printer.Meat.Common
3134import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
3235import Ormolu.Printer.Meat.Declaration.Signature
3336import Ormolu.Printer.Meat.Type
3437import Ormolu.Printer.Operators
3538import Ormolu.Utils
36−import RdrName (RdrName (..), rdrNameOcc)
37−import SrcLoc (combineSrcSpans, isOneLineSpan)
3839
3940-- | Style of a group of equations.
4041data MatchGroupStyle
@@ -60,16 +61,16 @@ 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
67− FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
68− PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
68+ FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
69+ PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
6970 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
7071 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
71− PatSynBind NoExt psb -> p_patSynBind psb
72− XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
72+ PatSynBind NoExtField psb -> p_patSynBind psb
73+ XHsBindsLR x -> noExtCon x
7374
7475p_funBind ::
7576 Located RdrName ->
@@ -113,8 +114,8 @@ p_matchGroup' placer render style MG {..} = do
113114 (matchStrictness m)
114115 m_pats
115116 m_grhss
116− p_Match _ = notImplemented "XMatch"
117−p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
117+ p_Match (XMatch x) = noExtCon x
118+p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
118119
119120-- | Function id obtained through pattern matching on 'FunBind' should not
120121-- be used to print the actual equations because the different ‘RdrNames’
@@ -179,27 +180,26 @@ 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
195− let stdCase = sep breakpoint p_pat m_pats
195+ 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)
202− (p_pat <$> m_pats)
202+ (located' p_pat <$> m_pats)
203203 PatternBind -> stdCase
204204 Case -> stdCase
205205 Lambda -> do
@@ -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,11 +253,18 @@ 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
268−p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"
267+p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
269268
270269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
271270p_grhs = p_grhs' exprPlacement p_hsExpr
@@ -279,79 +278,109 @@ p_grhs' ::
279278 GroupStyle ->
280279 GRHS GhcPs (Located body) ->
281280 R ()
282−p_grhs' placer render style (GRHS NoExt guards body) =
281+p_grhs' placer render style (GRHS NoExtField guards body) =
283282 case guards of
284283 [] -> p_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
307−p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
306+p_grhs' _ _ _ (XGRHS x) = noExtCon x
308307
309308p_hsCmd :: HsCmd GhcPs -> R ()
310309p_hsCmd = \case
311− HsCmdArrApp NoExt body input arrType _ -> do
310+ 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 NoExt 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
323323 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
324− HsCmdArrForm NoExt form Infix _ [left, right] -> do
324+ HsCmdArrForm NoExtField form Infix _ [left, right] -> do
325325 located left p_hsCmdTop
326326 space
327327 located form p_hsExpr
328328 placeHanging (cmdTopPlacement (unLoc right)) $
329329 located right p_hsCmdTop
330− HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
330+ HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
331331 HsCmdApp {} ->
332332 -- XXX Does this ever occur in the syntax tree? It does not seem like it
333333 -- does. Open an issue and ping @yumiova if this ever occurs in output.
334334 notImplemented "HsCmdApp"
335− HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
336− HsCmdPar NoExt c -> parens N (located c p_hsCmd)
337− HsCmdCase NoExt e mgroup ->
335+ HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
336+ HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
337+ HsCmdCase NoExtField e mgroup ->
338338 p_case cmdPlacement p_hsCmd e mgroup
339− HsCmdIf NoExt _ if' then' else' ->
339+ HsCmdIf NoExtField _ if' then' else' ->
340340 p_if cmdPlacement p_hsCmd if' then' else'
341− HsCmdLet NoExt localBinds c ->
341+ HsCmdLet NoExtField localBinds c ->
342342 p_let p_hsCmd localBinds c
343− HsCmdDo NoExt es -> do
343+ HsCmdDo NoExtField es -> do
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"
349− XCmd {} -> notImplemented "XCmd"
349+ XCmd x -> noExtCon x
350350
351351p_hsCmdTop :: HsCmdTop GhcPs -> R ()
352352p_hsCmdTop = \case
353− HsCmdTop NoExt cmd -> located cmd p_hsCmd
354− XCmdTop {} -> notImplemented "XHsCmdTop"
353+ HsCmdTop NoExtField cmd -> located cmd p_hsCmd
354+ XCmdTop x -> noExtCon x
355+
356+-- | Render an expression preserving blank lines between such consecutive
357+-- expressions found in the original source code.
358+withSpacing ::
359+ -- | Rendering function
360+ (a -> R ()) ->
361+ -- | Entity to render
362+ Located a ->
363+ R ()
364+withSpacing f l = located l $ \x -> do
365+ case getLoc l of
366+ UnhelpfulSpan _ -> f x
367+ RealSrcSpan currentSpn -> do
368+ getSpanMark >>= \case
369+ -- Spacing before comments will be handled by the code
370+ -- that prints comments, so we just have to deal with
371+ -- blank lines between statements here.
372+ Just (StatementSpan lastSpn) ->
373+ if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1
374+ then newline
375+ else return ()
376+ _ -> return ()
377+ f x
378+ -- In some cases the (f x) expression may insert a new mark. We want
379+ -- to be careful not to override comment marks.
380+ getSpanMark >>= \case
381+ Just (HaddockSpan _ _) -> return ()
382+ Just (CommentSpan _) -> return ()
383+ _ -> setSpanMark (StatementSpan currentSpn)
355384
356385p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
357386p_stmt = p_stmt' exprPlacement p_hsExpr
@@ -366,16 +395,13 @@ p_stmt' ::
366395 Stmt GhcPs (Located body) ->
367396 R ()
368397p_stmt' placer render = \case
369− LastStmt NoExt body _ _ -> located body render
370− BindStmt NoExt p f _ _ -> do
371− p_pat p
398+ LastStmt NoExtField body _ _ -> located body render
399+ BindStmt NoExtField p f _ _ -> do
400+ located p p_pat
372401 space
373402 txt "<-"
374− -- https://gitlab.haskell.org/ghc/ghc/issues/17330
375− let loc = case p of
376− XPat pat -> getLoc pat
377− _ -> error "p_stmt': BindStmt: Pat does not contain a location"
378− let placement =
403+ let loc = getLoc p
404+ placement =
379405 case f of
380406 L l' x ->
381407 if isOneLineSpan
@@ -385,8 +411,8 @@ p_stmt' placer render = \case
385411 switchLayout [loc, getLoc f] $
386412 placeHanging placement (located f render)
387413 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
388− BodyStmt NoExt body _ _ -> located body render
389− LetStmt NoExt binds -> do
414+ BodyStmt NoExtField body _ _ -> located body render
415+ LetStmt NoExtField binds -> do
390416 txt "let"
391417 space
392418 sitcc $ located binds p_hsLocalBinds
@@ -427,11 +453,11 @@ p_stmt' placer render = \case
427453 RecStmt {..} -> do
428454 txt "rec"
429455 space
430− sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
431− XStmtLR {} -> notImplemented "XStmtLR"
456+ sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
457+ XStmtLR c -> noExtCon c
432458
433459gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
434−gatherStmt (L _ (ParStmt NoExt block _ _)) =
460+gatherStmt (L _ (ParStmt NoExtField block _ _)) =
435461 foldr ((<>) . gatherStmtBlock) [] block
436462gatherStmt (L s stmt@TransStmt {..}) =
437463 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
@@ -440,46 +466,46 @@ gatherStmt stmt = [[stmt]]
440466gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
441467gatherStmtBlock (ParStmtBlock _ stmts _ _) =
442468 foldr (liftAppend . gatherStmt) [] stmts
443−gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
469+gatherStmtBlock (XParStmtBlock x) = noExtCon x
444470
445471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
446472p_hsLocalBinds = \case
447− HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
448− let ssStart =
449− either
450− (srcSpanStart . getLoc)
451− (srcSpanStart . getLoc)
452− items =
453− (Left <$> bagToList bag) ++ (Right <$> lsigs)
454− p_item (Left x) = located x p_valDecl
455− p_item (Right x) = located x p_sigDecl
456− -- Assigns 'False' to the last element, 'True' to the rest.
457− markInit :: [a] -> [(Bool, a)]
458− markInit [] = []
459− markInit [x] = [(False, x)]
460− markInit (x : xs) = (True, x) : markInit xs
473+ HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
461474 -- When in a single-line layout, there is a chance that the inner
462475 -- elements will also contain semicolons and they will confuse the
463476 -- parser. so we request braces around every element except the last.
464477 br <- layoutToBraces <$> getLayout
465− sitcc $
466− sepSemi
467− (\(m, i) -> (if m then br else id) $ p_item i)
468− (markInit $ sortOn ssStart items)
469− HsValBinds NoExt _ -> notImplemented "HsValBinds"
470− HsIPBinds NoExt (IPBinds NoExt xs) ->
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)
492+ HsValBinds NoExtField _ -> notImplemented "HsValBinds"
493+ HsIPBinds NoExtField (IPBinds NoExtField xs) ->
471494 -- Second argument of IPBind is always Left before type-checking.
472− let p_ipBind (IPBind NoExt (Left name) expr) = do
495+ let p_ipBind (IPBind NoExtField (Left name) expr) = do
473496 atom name
474497 space
475− txt "="
498+ equals
476499 breakpoint
477500 useBraces $ inci $ located expr p_hsExpr
478− p_ipBind _ = notImplemented "XHsIPBinds"
501+ p_ipBind (IPBind NoExtField (Right _) _) =
502+ -- Should only occur after the type checker
503+ notImplemented "IPBind _ (Right _) _"
504+ p_ipBind (XIPBind x) = noExtCon x
479505 in sepSemi (located' p_ipBind) xs
480− HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
481− EmptyLocalBinds NoExt -> return ()
482− XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
506+ HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
507+ EmptyLocalBinds NoExtField -> return ()
508+ XHsLocalBindsLR x -> noExtCon x
483509
484510p_hsRecField ::
485511 HsRecField' RdrName (LHsExpr GhcPs) ->
@@ -488,48 +514,45 @@ 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 NoExt x -> located x p_hsExpr
498− Missing NoExt -> pure ()
499− XTupArg {} -> notImplemented "XTupArg"
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
503526
504527p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
505528p_hsExpr' s = \case
506− HsVar NoExt name -> p_rdrName name
507− HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
508− HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
509− HsRecFld NoExt x ->
529+ HsVar NoExtField name -> p_rdrName name
530+ HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
531+ HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
532+ HsRecFld NoExtField x ->
510533 case x of
511− Unambiguous NoExt name -> p_rdrName name
512− Ambiguous NoExt name -> p_rdrName name
513− XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
514− HsOverLabel NoExt _ v -> do
534+ Unambiguous NoExtField name -> p_rdrName name
535+ Ambiguous NoExtField name -> p_rdrName name
536+ XAmbiguousFieldOcc xx -> noExtCon xx
537+ HsOverLabel NoExtField _ v -> do
515538 txt "#"
516539 atom v
517− HsIPVar NoExt (HsIPName name) -> do
540+ HsIPVar NoExtField (HsIPName name) -> do
518541 txt "?"
519542 atom name
520− HsOverLit NoExt v -> atom (ol_val v)
521− HsLit NoExt lit ->
543+ HsOverLit NoExtField v -> atom (ol_val v)
544+ HsLit NoExtField lit ->
522545 case lit of
523546 HsString (SourceText stxt) _ -> p_stringLit stxt
524547 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
525548 r -> atom r
526− HsLam NoExt mgroup ->
549+ HsLam NoExtField mgroup ->
527550 p_matchGroup Lambda mgroup
528− HsLamCase NoExt mgroup -> do
551+ HsLamCase NoExtField mgroup -> do
529552 txt "\\case"
530553 breakpoint
531554 inci (p_matchGroup LambdaCase mgroup)
532− HsApp NoExt f x -> do
555+ HsApp NoExtField f x -> do
533556 let -- In order to format function applications with multiple parameters
534557 -- nicer, traverse the AST to gather the function and all the
535558 -- parameters together.
@@ -541,8 +564,10 @@ p_hsExpr' s = \case
541564 -- We need to handle the last argument specially if it is a
542565 -- hanging construct, so separate it from the rest.
543566 (initp, lastp) = (NE.init args, NE.last args)
544− initSpan = combineSrcSpans' $ getLoc f :| map getLoc initp
545− -- Hang the last argument only if the initial arguments spans one
567+ initSpan =
568+ combineSrcSpans' $
569+ getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]
570+ -- Hang the last argument only if the initial arguments span one
546571 -- line.
547572 placement =
548573 if isOneLineSpan initSpan
@@ -559,21 +584,21 @@ p_hsExpr' s = \case
559584 -- do-block or case expression it is not a good idea. It seems
560585 -- to be safe to always bump indentation when the function
561586 -- expression is parenthesised.
562− indent =
587+ doIndent =
563588 case func of
564− L _ (HsPar NoExt _) -> inci
565− L spn _ ->
566− if isOneLineSpan spn
567− then inci
568− else id
569− ub <- getLayout <&> \case
570− SingleLine -> useBraces
571− 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
572597 ub $ do
573598 located func (p_hsExpr' s)
574599 breakpoint
575− indent $ sep breakpoint (located' p_hsExpr) initp
576− indent $ do
600+ inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601+ inciIf doIndent $ do
577602 unless (null initp) breakpoint
578603 located lastp p_hsExpr
579604 Hanging -> do
@@ -583,75 +608,87 @@ p_hsExpr' s = \case
583608 sep breakpoint (located' p_hsExpr) initp
584609 placeHanging placement $
585610 located lastp p_hsExpr
586− HsAppType NoExt e a -> do
611+ HsAppType NoExtField e a -> do
587612 located e p_hsExpr
588613 breakpoint
589614 inci $ do
590615 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 ()
591621 located (hswc_body a) p_hsType
592− OpApp NoExt x op y -> do
622+ OpApp NoExtField x op y -> do
593623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
594− p_exprOpTree True s (reassociateOpTree getOpName opTree)
595− NegApp NoExt e _ -> do
624+ p_exprOpTree s (reassociateOpTree getOpName opTree)
625+ NegApp NoExtField e _ -> do
596626 txt "-"
597627 space
598628 located e p_hsExpr
599− HsPar NoExt e ->
629+ HsPar NoExtField e ->
600630 parens s (located e (dontUseBraces . p_hsExpr))
601− SectionL NoExt x op -> do
631+ SectionL NoExtField x op -> do
602632 located x p_hsExpr
603633 breakpoint
604634 inci (located op p_hsExpr)
605− SectionR NoExt op x -> do
635+ SectionR NoExtField op x -> do
606636 located op p_hsExpr
607− breakpoint
637+ useRecordDot' <- useRecordDot
638+ let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
639+ unless (useRecordDot' && isRecordDot') breakpoint
608640 inci (located x p_hsExpr)
609− ExplicitTuple NoExt args boxity -> do
641+ ExplicitTuple NoExtField args boxity ->
610642 let isSection = any (isMissing . unLoc) args
611643 isMissing = \case
612− Missing NoExt -> True
644+ Missing NoExtField -> True
613645 _ -> False
614− 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' =
615652 case boxity of
616653 Boxed -> parens
617654 Unboxed -> parensHash
618− if isSection
619− then
620− switchLayout [] . parens' s $
621− sep comma (located' p_hsTupArg) args
622− else
623− switchLayout (getLoc <$> args) . parens' s . sitcc $
624− sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
625− ExplicitSum NoExt tag arity e ->
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
662+ ExplicitSum NoExtField tag arity e ->
626663 p_unboxedSum N tag arity (located e p_hsExpr)
627− HsCase NoExt e mgroup ->
664+ HsCase NoExtField e mgroup ->
628665 p_case exprPlacement p_hsExpr e mgroup
629− HsIf NoExt _ if' then' else' ->
666+ HsIf NoExtField _ if' then' else' ->
630667 p_if exprPlacement p_hsExpr if' then' else'
631− HsMultiIf NoExt guards -> do
668+ HsMultiIf NoExtField guards -> do
632669 txt "if"
633670 breakpoint
634− inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
635− HsLet NoExt localBinds e ->
671+ inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
672+ HsLet NoExtField localBinds e ->
636673 p_let p_hsExpr localBinds e
637− HsDo NoExt ctx es -> do
674+ HsDo NoExtField ctx es -> do
638675 let doBody header = do
639676 txt header
640677 breakpoint
641678 ub <- layoutToBraces <$> getLayout
642679 inci $
643680 sepSemi
644− (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
681+ (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
645682 (unLoc es)
646− compBody = brackets N $ located es $ \xs -> do
683+ compBody = brackets N . located es $ \xs -> do
647684 let p_parBody =
648685 sep
649− (breakpoint >> txt "| ")
686+ (breakpoint >> txt "|" >> space)
650687 p_seqBody
651688 p_seqBody =
652689 sitcc
653690 . sep
654− (comma >> breakpoint)
691+ commaDel
655692 (located' (sitcc . p_stmt))
656693 stmts = init xs
657694 yield = last xs
@@ -672,90 +709,96 @@ p_hsExpr' s = \case
672709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
673710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
674711 ExplicitList _ _ xs ->
675− brackets s . sitcc $
676− sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
712+ brackets s $
713+ sep commaDel (sitcc . located' p_hsExpr) xs
677714 RecordCon {..} -> do
678715 located rcon_con_name atom
679716 breakpoint
680717 let HsRecFields {..} = rcon_flds
681718 updName f =
682− f
719+ (f :: HsRecField GhcPs (LHsExpr GhcPs))
683720 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
684721 FieldOcc _ n -> n
685− XFieldOcc _ -> notImplemented "XFieldOcc"
722+ XFieldOcc x -> noExtCon x
686723 }
687724 fields = located' (p_hsRecField . updName) <$> rec_flds
688725 dotdot =
689726 case rec_dotdot of
690727 Just {} -> [txt ".."]
691728 Nothing -> []
692− inci . braces N . sitcc $
693− sep (comma >> breakpoint) sitcc (fields <> dotdot)
729+ inci . braces N $
730+ sep commaDel sitcc (fields <> dotdot)
694731 RecordUpd {..} -> do
695732 located rupd_expr p_hsExpr
696− breakpoint
733+ useRecordDot' <- useRecordDot
734+ let mrs sp = case getLoc sp of
735+ RealSrcSpan r -> Just r
736+ _ -> Nothing
737+ let isPluginForm =
738+ ((1 +) . srcSpanEndCol <$> mrs rupd_expr)
739+ == (srcSpanStartCol <$> mrs (head rupd_flds))
740+ unless (useRecordDot' && isPluginForm) breakpoint
697741 let updName f =
698− f
742+ (f :: HsRecUpdField GhcPs)
699743 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
700744 Ambiguous _ n -> n
701745 Unambiguous _ n -> n
702− XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
746+ XAmbiguousFieldOcc x -> noExtCon x
703747 }
704− inci . braces N . sitcc $
748+ inci . braces N $
705749 sep
706− (comma >> breakpoint)
750+ commaDel
707751 (sitcc . located' (p_hsRecField . updName))
708752 rupd_flds
709− ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
753+ ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
710754 located x p_hsExpr
711755 space
712756 txt "::"
713757 breakpoint
714758 inci $ located hsib_body p_hsType
715− ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->
716− notImplemented "XHsImplicitBndrs"
717− ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"
718− ArithSeq NoExt _ x ->
759+ ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
760+ ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
761+ ArithSeq NoExtField _ x ->
719762 case x of
720− From from -> brackets s . sitcc $ do
763+ From from -> brackets s $ do
721764 located from p_hsExpr
722765 breakpoint
723766 txt ".."
724− FromThen from next -> brackets s . sitcc $ do
725− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
767+ FromThen from next -> brackets s $ do
768+ sep commaDel (located' p_hsExpr) [from, next]
726769 breakpoint
727770 txt ".."
728− FromTo from to -> brackets s . sitcc $ do
771+ FromTo from to -> brackets s $ do
729772 located from p_hsExpr
730773 breakpoint
731774 txt ".."
732775 space
733776 located to p_hsExpr
734− FromThenTo from next to -> brackets s . sitcc $ do
735− 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]
736779 breakpoint
737780 txt ".."
738781 space
739782 located to p_hsExpr
740− HsSCC NoExt _ name x -> do
783+ HsSCC NoExtField _ name x -> do
741784 txt "{-# SCC "
742785 atom name
743786 txt " #-}"
744787 breakpoint
745788 located x p_hsExpr
746− HsCoreAnn NoExt _ value x -> do
789+ HsCoreAnn NoExtField _ value x -> do
747790 txt "{-# CORE "
748791 atom value
749792 txt " #-}"
750793 breakpoint
751794 located x p_hsExpr
752− HsBracket NoExt x -> p_hsBracket x
795+ HsBracket NoExtField x -> p_hsBracket x
753796 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
754797 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
755− HsSpliceE NoExt splice -> p_hsSplice splice
756− HsProc NoExt p e -> do
798+ HsSpliceE NoExtField splice -> p_hsSplice splice
799+ HsProc NoExtField p e -> do
757800 txt "proc"
758− locatedPat p $ \x -> do
801+ located p $ \x -> do
759802 breakpoint
760803 inci (p_pat x)
761804 breakpoint
@@ -766,31 +809,11 @@ p_hsExpr' s = \case
766809 txt "static"
767810 breakpoint
768811 inci (located e p_hsExpr)
769− HsArrApp NoExt body input arrType cond ->
770− p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
771− HsArrForm NoExt form mfixity cmds ->
772− p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
773812 HsTick {} -> notImplemented "HsTick"
774813 HsBinTick {} -> notImplemented "HsBinTick"
775814 HsTickPragma {} -> notImplemented "HsTickPragma"
776− -- These four constructs should never appear in correct programs.
777− -- See: https://github.com/tweag/ormolu/issues/343
778− EWildPat NoExt -> txt "_"
779− EAsPat NoExt n p -> do
780− p_rdrName n
781− txt "@"
782− located p p_hsExpr
783− EViewPat NoExt p e -> do
784− located p p_hsExpr
785− space
786− txt "->"
787− breakpoint
788− inci (located e p_hsExpr)
789− ELazyPat NoExt p -> do
790− txt "~"
791− located p p_hsExpr
792815 HsWrap {} -> notImplemented "HsWrap"
793− XExpr {} -> notImplemented "XExpr"
816+ XExpr x -> noExtCon x
794817
795818p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
796819p_patSynBind PSB {..} = do
@@ -800,15 +823,15 @@ p_patSynBind PSB {..} = do
800823 Unidirectional -> do
801824 txt "<-"
802825 breakpoint
803− p_pat psb_def
826+ located psb_def p_pat
804827 ImplicitBidirectional -> do
805− txt "="
828+ equals
806829 breakpoint
807− p_pat psb_def
830+ located psb_def p_pat
808831 ExplicitBidirectional mgroup -> do
809832 txt "<-"
810833 breakpoint
811− p_pat psb_def
834+ located psb_def p_pat
812835 newline
813836 txt "where"
814837 newline
@@ -829,8 +852,8 @@ p_patSynBind PSB {..} = do
829852 inci $ do
830853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
831854 unless (null xs) breakpoint
832− braces N . sitcc $
833− sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
855+ braces N $
856+ sep commaDel (p_rdrName . recordPatSynPatVar) xs
834857 rhs
835858 InfixCon l r -> do
836859 switchLayout [getLoc l, getLoc r] $ do
@@ -842,7 +865,7 @@ p_patSynBind PSB {..} = do
842865 space
843866 p_rdrName r
844867 inci rhs
845−p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
868+p_patSynBind (XPatSynBind x) = noExtCon x
846869
847870p_case ::
848871 Data body =>
@@ -884,10 +907,12 @@ p_if placer render if' then' else' = do
884907 breakpoint
885908 inci $ do
886909 txt "then"
910+ space
887911 located then' $ \x ->
888912 placeHanging (placer x) (render x)
889913 breakpoint
890914 txt "else"
915+ space
891916 located else' $ \x ->
892917 placeHanging (placer x) (render x)
893918
@@ -909,77 +934,77 @@ p_let render localBinds e = sitcc $ do
909934
910935p_pat :: Pat GhcPs -> R ()
911936p_pat = \case
912− -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always
913− -- constructed with the 'XPat' constructor, containing a @Located Pat@.
914− XPat pat -> located pat p_pat
915− WildPat NoExt -> txt "_"
916− VarPat NoExt name -> p_rdrName name
917− LazyPat NoExt pat -> do
937+ WildPat NoExtField -> txt "_"
938+ VarPat NoExtField name -> p_rdrName name
939+ LazyPat NoExtField pat -> do
918940 txt "~"
919− p_pat pat
920− AsPat NoExt name pat -> do
941+ located pat p_pat
942+ AsPat NoExtField name pat -> do
921943 p_rdrName name
922944 txt "@"
923− p_pat pat
924− ParPat NoExt pat ->
925− locatedPat pat (parens S . p_pat)
926− BangPat NoExt pat -> do
945+ located pat p_pat
946+ ParPat NoExtField pat ->
947+ located pat (parens S . p_pat)
948+ BangPat NoExtField pat -> do
927949 txt "!"
928− p_pat pat
929− ListPat NoExt pats ->
930− brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats
931− TuplePat NoExt pats boxing -> do
932− let f =
950+ located pat p_pat
951+ ListPat NoExtField pats ->
952+ brackets S $ sep commaDel (located' p_pat) pats
953+ TuplePat NoExtField pats boxing -> do
954+ let parens' =
933955 case boxing of
934956 Boxed -> parens S
935957 Unboxed -> parensHash S
936− f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats
937− SumPat NoExt pat tag arity ->
938− p_unboxedSum S tag arity (p_pat pat)
958+ parens' $ sep commaDel (sitcc . located' p_pat) pats
959+ SumPat NoExtField pat tag arity ->
960+ p_unboxedSum S tag arity (located pat p_pat)
939961 ConPatIn pat details ->
940962 case details of
941963 PrefixCon xs -> sitcc $ do
942964 p_rdrName pat
943965 unless (null xs) $ do
944966 breakpoint
945− inci . sitcc $ sep breakpoint (sitcc . p_pat) xs
967+ inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs
946968 RecCon (HsRecFields fields dotdot) -> do
947969 p_rdrName pat
948970 breakpoint
949971 let f = \case
950972 Nothing -> txt ".."
951973 Just x -> located x p_pat_hsRecField
952− inci . braces N . sitcc . sep (comma >> breakpoint) f $
974+ inci . braces N . sep commaDel f $
953975 case dotdot of
954976 Nothing -> Just <$> fields
955− Just n -> (Just <$> take n fields) ++ [Nothing]
956− InfixCon x y -> do
957− p_pat x
958− space
959− p_rdrName pat
960− breakpoint
961− inci (p_pat y)
977+ Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]
978+ InfixCon l r -> do
979+ switchLayout [getLoc l, getLoc r] $ do
980+ located l p_pat
981+ breakpoint
982+ inci $ do
983+ p_rdrName pat
984+ space
985+ located r p_pat
962986 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
963− ViewPat NoExt expr pat -> sitcc $ do
987+ ViewPat NoExtField expr pat -> sitcc $ do
964988 located expr p_hsExpr
965989 space
966990 txt "->"
967991 breakpoint
968− inci (p_pat pat)
969− SplicePat NoExt splice -> p_hsSplice splice
970− LitPat NoExt p -> atom p
971− NPat NoExt v _ _ -> located v (atom . ol_val)
972− NPlusKPat NoExt n k _ _ _ -> sitcc $ do
992+ inci (located pat p_pat)
993+ SplicePat NoExtField splice -> p_hsSplice splice
994+ LitPat NoExtField p -> atom p
995+ NPat NoExtField v _ _ -> located v (atom . ol_val)
996+ NPlusKPat NoExtField n k _ _ _ -> sitcc $ do
973997 p_rdrName n
974998 breakpoint
975999 inci $ do
9761000 txt "+"
9771001 space
9781002 located k (atom . ol_val)
979− SigPat NoExt pat hswc -> do
980− p_pat pat
1003+ SigPat NoExtField pat hswc -> do
1004+ located pat p_pat
9811005 p_typeAscription hswc
9821006 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
1007+ XPat x -> noExtCon x
9831008
9841009p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
9851010p_pat_hsRecField HsRecField {..} = do
@@ -987,32 +1012,30 @@ p_pat_hsRecField HsRecField {..} = do
9871012 p_rdrName (rdrNameFieldOcc x)
9881013 unless hsRecPun $ do
9891014 space
990− txt "="
1015+ equals
9911016 breakpoint
992− inci (p_pat hsRecFieldArg)
1017+ inci (located hsRecFieldArg p_pat)
9931018
9941019p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
9951020p_unboxedSum s tag arity m = do
9961021 let before = tag - 1
9971022 after = arity - before - 1
9981023 args = replicate before Nothing <> [Just m] <> replicate after Nothing
999− f (x, i) = do
1000− let isFirst = i == 0
1001− isLast = i == arity - 1
1024+ f x =
10021025 case x :: Maybe (R ()) of
10031026 Nothing ->
1004− unless (isFirst || isLast) space
1027+ space
10051028 Just m' -> do
1006− unless isFirst space
1029+ space
10071030 m'
1008− unless isLast space
1009− parensHash s $ sep (txt "|") f (zip args [0 ..])
1031+ space
1032+ parensHash s $ sep (txt "|") f args
10101033
10111034p_hsSplice :: HsSplice GhcPs -> R ()
10121035p_hsSplice = \case
1013− HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
1014− HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
1015− HsQuasiQuote NoExt _ quoterName srcSpan str -> do
1036+ HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco
1037+ HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco
1038+ HsQuasiQuote NoExtField _ quoterName srcSpan str -> do
10161039 txt "["
10171040 p_rdrName (L srcSpan quoterName)
10181041 txt "|"
@@ -1022,7 +1045,7 @@ p_hsSplice = \case
10221045 txt "|]"
10231046 HsSpliced {} -> notImplemented "HsSpliced"
10241047 HsSplicedT {} -> notImplemented "HsSplicedT"
1025− XSplice {} -> notImplemented "XSplice"
1048+ XSplice x -> noExtCon x
10261049
10271050p_hsSpliceTH ::
10281051 -- | Typed splice?
@@ -1046,17 +1069,17 @@ p_hsSpliceTH isTyped expr = \case
10461069
10471070p_hsBracket :: HsBracket GhcPs -> R ()
10481071p_hsBracket = \case
1049− ExpBr NoExt expr -> do
1072+ ExpBr NoExtField expr -> do
10501073 anns <- getEnclosingAnns
10511074 let name = case anns of
10521075 AnnOpenEQ : _ -> ""
10531076 _ -> "e"
10541077 quote name (located expr p_hsExpr)
1055− PatBr NoExt pat -> quote "p" (p_pat pat)
1056− DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
1057− DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
1058− TypBr NoExt ty -> quote "t" (located ty p_hsType)
1059− VarBr NoExt isSingleQuote name -> do
1078+ PatBr NoExtField pat -> located pat (quote "p" . p_pat)
1079+ DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)
1080+ DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer
1081+ TypBr NoExtField ty -> quote "t" (located ty p_hsType)
1082+ VarBr NoExtField isSingleQuote name -> do
10601083 txt (bool "''" "'" isSingleQuote)
10611084 -- HACK As you can see we use 'noLoc' here to be able to pass name into
10621085 -- 'p_rdrName' since the latter expects a "located" thing. The problem
@@ -1071,13 +1094,13 @@ p_hsBracket = \case
10711094 && not (doesNotNeedExtraParens name)
10721095 wrapper = if isOperator then parens N else id
10731096 wrapper $ p_rdrName (noLoc name)
1074− TExpBr NoExt expr -> do
1097+ TExpBr NoExtField expr -> do
10751098 txt "[||"
10761099 breakpoint'
10771100 located expr p_hsExpr
10781101 breakpoint'
10791102 txt "||]"
1080− XBracket {} -> notImplemented "XBracket"
1103+ XBracket x -> noExtCon x
10811104 where
10821105 quote :: Text -> R () -> R ()
10831106 quote name body = do
@@ -1156,9 +1179,9 @@ liftAppend (x : xs) [] = x : xs
11561179liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
11571180
11581181getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
1159−getGRHSSpan (GRHS NoExt guards body) =
1182+getGRHSSpan (GRHS NoExtField guards body) =
11601183 combineSrcSpans' $ getLoc body :| map getLoc guards
1161−getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
1184+getGRHSSpan (XGRHS x) = noExtCon x
11621185
11631186-- | Place a thing that may have a hanging form. This function handles how
11641187-- to separate it from preceding expressions and whether to bump indentation
@@ -1179,79 +1202,74 @@ blockPlacement ::
11791202 (body -> Placement) ->
11801203 [LGRHS GhcPs (Located body)] ->
11811204 Placement
1182−blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x
1205+blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
11831206blockPlacement _ _ = Normal
11841207
11851208-- | Check if given command has a hanging form.
11861209cmdPlacement :: HsCmd GhcPs -> Placement
11871210cmdPlacement = \case
1188− HsCmdLam NoExt _ -> Hanging
1189− HsCmdCase NoExt _ _ -> Hanging
1190− HsCmdDo NoExt _ -> Hanging
1211+ HsCmdLam NoExtField _ -> Hanging
1212+ HsCmdCase NoExtField _ _ -> Hanging
1213+ HsCmdDo NoExtField _ -> Hanging
11911214 _ -> Normal
11921215
11931216cmdTopPlacement :: HsCmdTop GhcPs -> Placement
11941217cmdTopPlacement = \case
1195− HsCmdTop NoExt (L _ x) -> cmdPlacement x
1196− XCmdTop {} -> notImplemented "XCmdTop"
1218+ HsCmdTop NoExtField (L _ x) -> cmdPlacement x
1219+ XCmdTop x -> noExtCon x
11971220
11981221-- | Check if given expression has a hanging form.
11991222exprPlacement :: HsExpr GhcPs -> Placement
12001223exprPlacement = \case
12011224 -- Only hang lambdas with single line parameter lists
1202− HsLam NoExt mg -> case mg of
1203− MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
1225+ HsLam NoExtField mg -> case mg of
1226+ MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
12041227 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
12051228 Hanging
12061229 _ -> Normal
1207− HsLamCase NoExt _ -> Hanging
1208− HsCase NoExt _ _ -> Hanging
1209− HsDo NoExt DoExpr _ -> Hanging
1210− HsDo NoExt MDoExpr _ -> Hanging
1211− RecordCon NoExt _ _ -> Hanging
1212− -- If the rightmost expression in an operator chain is hanging, make the
1213− -- whole block hanging; so that we can use the common @f = foo $ do@
1214− -- style.
1215− OpApp NoExt _ _ y -> exprPlacement (unLoc y)
1216− -- Same thing for function applications (usually with -XBlockArguments)
1217− HsApp NoExt _ y -> exprPlacement (unLoc y)
1218− HsProc NoExt p _ ->
1219− -- https://gitlab.haskell.org/ghc/ghc/issues/17330
1220− let loc = case p of
1221− XPat pat -> getLoc pat
1222− _ -> error "exprPlacement: HsProc: Pat does not contain a location"
1223− in -- Indentation breaks if pattern is longer than one line and left
1224− -- hanging. Consequently, only apply hanging when it is safe.
1225− if isOneLineSpan loc
1226− then Hanging
1227− else Normal
1230+ HsLamCase NoExtField _ -> Hanging
1231+ HsCase NoExtField _ _ -> Hanging
1232+ HsDo NoExtField DoExpr _ -> Hanging
1233+ HsDo NoExtField MDoExpr _ -> Hanging
1234+ OpApp NoExtField _ op y ->
1235+ case (fmap getOpNameStr . getOpName . unLoc) op of
1236+ Just "$" -> exprPlacement (unLoc y)
1237+ _ -> Normal
1238+ HsApp NoExtField _ y -> exprPlacement (unLoc y)
1239+ HsProc NoExtField p _ ->
1240+ -- Indentation breaks if pattern is longer than one line and left
1241+ -- hanging. Consequently, only apply hanging when it is safe.
1242+ if isOneLineSpan (getLoc p)
1243+ then Hanging
1244+ else Normal
12281245 _ -> Normal
12291246
12301247withGuards :: [LGRHS GhcPs (Located body)] -> Bool
12311248withGuards = any (checkOne . unLoc)
12321249 where
12331250 checkOne :: GRHS GhcPs (Located body) -> Bool
1234− checkOne (GRHS NoExt [] _) = False
1251+ checkOne (GRHS NoExtField [] _) = False
12351252 checkOne _ = True
12361253
12371254exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1238−exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
1255+exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
12391256exprOpTree n = OpNode n
12401257
12411258getOpName :: HsExpr GhcPs -> Maybe RdrName
12421259getOpName = \case
1243− HsVar NoExt (L _ a) -> Just a
1260+ HsVar NoExtField (L _ a) -> Just a
12441261 _ -> Nothing
12451262
1263+getOpNameStr :: RdrName -> String
1264+getOpNameStr = occNameString . rdrNameOcc
1265+
12461266p_exprOpTree ::
1247− -- | Can use special handling of dollar?
1248− Bool ->
12491267 -- | Bracket style to use
12501268 BracketStyle ->
12511269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12521270 R ()
1253−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1254−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
12551273 -- If the beginning of the first argument and the second argument are on
12561274 -- the same line, and the second argument has a hanging form, use hanging
12571275 -- placement.
@@ -1262,8 +1280,10 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12621280 OpNode (L _ n) -> exprPlacement n
12631281 _ -> Normal
12641282 else Normal
1283+ -- Distinguish holes used in infix notation.
1284+ -- eg. '1 _foo 2' and '1 `_foo` 2'
12651285 opWrapper = case unLoc op of
1266− EWildPat NoExt -> backticks
1286+ HsUnboundVar NoExtField _ -> backticks
12671287 _ -> id
12681288 layout <- getLayout
12691289 let ub = case layout of
@@ -1271,27 +1291,67 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
12711291 MultiLine -> case placement of
12721292 Hanging -> useBraces
12731293 Normal -> dontUseBraces
1274− gotDollar = case getOpName (unLoc op) of
1275− Just rname -> mkVarOcc "$" == rdrNameOcc rname
1276− _ -> False
1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295+ gotDollar = opNameStr == Just "$"
1296+ gotColon = opNameStr == Just ":"
1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
12771298 lhs =
12781299 switchLayout [opTreeLoc x] $
1279− p_exprOpTree (not gotDollar) s x
1280− let p_op = located op (opWrapper . p_hsExpr)
1281− p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
1282− if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
1283− then do
1284− useBraces lhs
1285− space
1286− p_op
1287− breakpoint
1288− inci p_y
1289− else do
1290− ub lhs
1291− placeHanging placement $ do
1300+ p_exprOpTree s x
1301+ p_op = located op (opWrapper . p_hsExpr)
1302+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
1303+ isSection = case (opTreeLoc x, getLoc op) of
1304+ (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
1305+ srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
1306+ _ -> False
1307+ isDoBlock = \case
1308+ OpNode (L _ HsDo {}) -> True
1309+ _ -> False
1310+ useRecordDot' <- useRecordDot
1311+ if
1312+ | gotColon -> do
1313+ lhs
1314+ space
12921315 p_op
1316+ case placement of
1317+ Hanging -> do
1318+ space
1319+ p_y
1320+ Normal -> do
1321+ breakpoint
1322+ inciIf (isDoBlock y) p_y
1323+ | gotDollar
1324+ && isOneLineSpan (opTreeLoc x)
1325+ && placement == Normal -> do
1326+ useBraces lhs
12931327 space
1328+ p_op
1329+ breakpoint
1330+ inci p_y
1331+ | useRecordDot' && gotRecordDot -> do
1332+ lhs
1333+ when isSection space
1334+ p_op
12941335 p_y
1336+ | otherwise -> do
1337+ ub lhs
1338+ placeHanging placement $ do
1339+ p_op
1340+ space
1341+ p_y
1342+
1343+-- | Return 'True' if given expression is a record-dot operator expression.
1344+isRecordDot ::
1345+ -- | Operator expression
1346+ HsExpr GhcPs ->
1347+ -- | Span of the expression on the right-hand side of the operator
1348+ SrcSpan ->
1349+ Bool
1350+isRecordDot op (RealSrcSpan ySpan) = case op of
1351+ HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
1353+ _ -> False
1354+isRecordDot _ _ = False
12951355
12961356-- | Get annotations for the enclosing element.
12971357getEnclosingAnns :: R [AnnKeywordId]
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+9−13
@@ -13,32 +13,28 @@ import Data.Text (Text)
1313import GHC
1414import Ormolu.Printer.Combinators
1515import Ormolu.Printer.Meat.Common
16−import Ormolu.Utils
1716
1817p_warnDecls :: WarnDecls GhcPs -> R ()
19−p_warnDecls (Warnings NoExt _ warnings) =
18+p_warnDecls (Warnings NoExtField _ warnings) =
2019 traverse_ (located' p_warnDecl) warnings
21−p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"
20+p_warnDecls (XWarnDecls x) = noExtCon x
2221
2322p_warnDecl :: WarnDecl GhcPs -> R ()
24−p_warnDecl (Warning NoExt functions warningTxt) =
23+p_warnDecl (Warning NoExtField functions warningTxt) =
2524 p_topLevelWarning functions warningTxt
26−p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"
25+p_warnDecl (XWarnDecl x) = noExtCon x
2726
2827p_moduleWarning :: WarningTxt -> R ()
2928p_moduleWarning wtxt = do
3029 let (pragmaText, lits) = warningText wtxt
31− switchLayout (getLoc <$> lits)
32− $ inci
33− $ pragma pragmaText (inci $ p_lits lits)
30+ inci $ pragma pragmaText $ inci $ p_lits lits
3431
3532p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
3633p_topLevelWarning fnames wtxt = do
3734 let (pragmaText, lits) = warningText wtxt
38− switchLayout (fmap getLoc fnames ++ fmap getLoc lits)
39− $ pragma pragmaText . inci
40− $ do
41− 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
4238 breakpoint
4339 p_lits lits
4440
@@ -50,4 +46,4 @@ warningText = \case
5046p_lits :: [Located StringLiteral] -> R ()
5147p_lits = \case
5248 [l] -> atom l
53− ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls
49+ ls -> brackets N $ sep commaDel atom ls
src/Ormolu/Printer/Meat/ImportExport.hs+44−35
@@ -11,10 +11,9 @@ where
1111
1212import Control.Monad
1313import GHC
14−import HsImpExp (IE (..))
1514import Ormolu.Printer.Combinators
1615import Ormolu.Printer.Meat.Common
17−import Ormolu.Utils
16+import Ormolu.Utils (RelativePos (..), attachRelativePos)
1817
1918p_hsmodExports :: [LIE GhcPs] -> R ()
2019p_hsmodExports [] = do
@@ -22,19 +21,24 @@ p_hsmodExports [] = do
2221 breakpoint'
2322 txt ")"
2423p_hsmodExports xs =
25− parens N . sitcc $ do
24+ parens N $ do
2625 layout <- getLayout
27− 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)
2830
29−p_hsmodImport :: ImportDecl GhcPs -> R ()
30−p_hsmodImport ImportDecl {..} = do
31+p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
32+p_hsmodImport useQualifiedPost ImportDecl {..} = do
3133 txt "import"
3234 space
3335 when ideclSource (txt "{-# SOURCE #-}")
3436 space
3537 when ideclSafe (txt "safe")
3638 space
37− when ideclQualified (txt "qualified")
39+ when
40+ (isImportDeclQualified ideclQualified && not useQualifiedPost)
41+ (txt "qualified")
3842 space
3943 case ideclPkgQual of
4044 Nothing -> return ()
@@ -42,6 +46,9 @@ p_hsmodImport ImportDecl {..} = do
4246 space
4347 inci $ do
4448 located ideclName atom
49+ when
50+ (isImportDeclQualified ideclQualified && useQualifiedPost)
51+ (space >> txt "qualified")
4552 case ideclAs of
4653 Nothing -> return ()
4754 Just l -> do
@@ -58,60 +65,62 @@ p_hsmodImport ImportDecl {..} = do
5865 Nothing -> return ()
5966 Just (_, L _ xs) -> do
6067 breakpoint
61− parens N . sitcc $ do
68+ parens N $ do
6269 layout <- getLayout
63− 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)
6474 newline
65−p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"
75+p_hsmodImport _ (XImportDecl x) = noExtCon x
6676
67−p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
68−p_lie encLayout (i, totalItems) = \case
69− IEVar NoExt l1 -> do
77+p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
78+p_lie encLayout relativePos = \case
79+ IEVar NoExtField l1 -> do
7080 located l1 p_ieWrappedName
7181 p_comma
72− IEThingAbs NoExt l1 -> do
82+ IEThingAbs NoExtField l1 -> do
7383 located l1 p_ieWrappedName
7484 p_comma
75− IEThingAll NoExt l1 -> do
85+ IEThingAll NoExtField l1 -> do
7686 located l1 p_ieWrappedName
7787 space
7888 txt "(..)"
7989 p_comma
80− IEThingWith NoExt l1 w xs _ -> sitcc $ do
90+ IEThingWith NoExtField l1 w xs _ -> sitcc $ do
8191 located l1 p_ieWrappedName
8292 breakpoint
8393 inci $ do
8494 let names :: [R ()]
8595 names = located' p_ieWrappedName <$> xs
86− parens N . sitcc
87− $ sep (comma >> breakpoint) sitcc
88− $ case w of
96+ parens N . sep commaDel sitcc $
97+ case w of
8998 NoIEWildcard -> names
9099 IEWildcard n ->
91100 let (before, after) = splitAt n names
92101 in before ++ [txt ".."] ++ after
93102 p_comma
94− IEModuleContents NoExt l1 -> do
103+ IEModuleContents NoExtField l1 -> do
95104 located l1 p_hsmodName
96105 p_comma
97− IEGroup NoExt n str -> do
98− unless (i == 0) newline
106+ IEGroup NoExtField n str -> do
107+ case relativePos of
108+ SinglePos -> return ()
109+ FirstPos -> return ()
110+ MiddlePos -> newline
111+ LastPos -> newline
99112 p_hsDocString (Asterisk n) False (noLoc str)
100− IEDoc NoExt str ->
113+ IEDoc NoExtField str ->
101114 p_hsDocString Pipe False (noLoc str)
102− IEDocNamed NoExt str -> p_hsDocName str
103− XIE NoExt -> notImplemented "XIE"
115+ IEDocNamed NoExtField str -> p_hsDocName str
116+ XIE x -> noExtCon x
104117 where
105118 p_comma =
106119 case encLayout of
107− SingleLine -> unless (i + 1 == totalItems) comma
120+ SingleLine ->
121+ case relativePos of
122+ SinglePos -> return ()
123+ FirstPos -> comma
124+ MiddlePos -> comma
125+ LastPos -> return ()
108126 MultiLine -> comma
109−
110−-- | Attach positions to 'Located' things in a list.
111−attachPositions ::
112− [Located a] ->
113− [Located ((Int, Int), a)]
114−attachPositions xs =
115− let f i (L l x) = L l ((i, n), x)
116− n = length xs
117− in zipWith f [0 ..] xs
src/Ormolu/Printer/Meat/Module.hs+26−20
@@ -1,3 +1,4 @@
1+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE RecordWildCards #-}
34
@@ -10,8 +11,10 @@ where
1011import Control.Monad
1112import qualified Data.Text as T
1213import GHC
13−import Ormolu.Imports
14+import Ormolu.Imports (normalizeImports)
15+import Ormolu.Parser.CommentStream
1416import Ormolu.Parser.Pragma
17+import Ormolu.Parser.Shebang
1518import Ormolu.Printer.Combinators
1619import Ormolu.Printer.Comments
1720import Ormolu.Printer.Meat.Common
@@ -22,26 +25,28 @@ import Ormolu.Printer.Meat.Pragma
2225
2326-- | Render a module.
2427p_hsModule ::
28+ -- | Stack header
29+ Maybe (RealLocated Comment) ->
2530 -- | Shebangs
26− [Located String] ->
27− -- | Pragmas
28− [Pragma] ->
31+ [Shebang] ->
32+ -- | Pragmas and the associated comments
33+ [([RealLocated Comment], Pragma)] ->
34+ -- | Whether to use postfix qualified imports
35+ Bool ->
2936 -- | AST to print
30− ParsedSource ->
37+ HsModule GhcPs ->
3138 R ()
32−p_hsModule shebangs pragmas (L moduleSpan HsModule {..}) = do
33− -- If span of exports in multiline, the whole thing is multiline. This is
34− -- especially important because span of module itself always seems to have
35− -- length zero, so it's not reliable for layout selection.
36− let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
37− deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
38− spans' = exportSpans ++ deprecSpan ++ [moduleSpan]
39− switchLayout spans' $ do
40− 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) ->
4144 located x $ \shebang -> do
4245 txt (T.pack shebang)
4346 newline
44− spitStackHeader
47+ forM_ mstackHeader $ \(L spn comment) -> do
48+ spitCommentNow spn comment
49+ newline
4550 newline
4651 p_pragmas pragmas
4752 newline
@@ -51,19 +56,20 @@ p_hsModule shebangs pragmas (L moduleSpan HsModule {..}) = do
5156 located hsmodName' $ \name -> do
5257 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
5358 p_hsmodName name
59+ breakpoint
5460 forM_ hsmodDeprecMessage $ \w -> do
55− breakpoint
5661 located' p_moduleWarning w
62+ breakpoint
5763 case hsmodExports of
5864 Nothing -> return ()
59− Just hsmodExports' -> do
65+ Just l -> do
66+ located l $ \exports -> do
67+ inci (p_hsmodExports exports)
6068 breakpoint
61− inci (p_hsmodExports (unLoc hsmodExports'))
62− breakpoint
6369 txt "where"
6470 newline
6571 newline
66− forM_ (sortImports hsmodImports) (located' p_hsmodImport)
72+ forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
6773 newline
6874 switchLayout (getLoc <$> hsmodDecls) $ do
6975 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+85−61
@@ -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,15 +24,23 @@ 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
30− HsForAllTy NoExt bndrs t -> do
31− p_forallBndrs p_hsTyVarBndr bndrs
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
39+ HsForAllTy NoExtField visibility bndrs t -> do
40+ p_forallBndrs visibility p_hsTyVarBndr bndrs
3241 interArgBreak
33− p_hsType' multilineArgs (unLoc t)
34− HsQualTy NoExt qs t -> do
42+ p_hsTypeR (unLoc t)
43+ HsQualTy NoExtField qs t -> do
3544 located qs p_hsContext
3645 space
3746 txt "=>"
@@ -40,7 +49,7 @@ p_hsType' multilineArgs = \case
4049 HsQualTy {} -> p_hsTypeR (unLoc t)
4150 HsFunTy {} -> p_hsTypeR (unLoc t)
4251 _ -> located t p_hsTypeR
43− HsTyVar NoExt p n -> do
52+ HsTyVar NoExtField p n -> do
4453 case p of
4554 IsPromoted -> do
4655 txt "'"
@@ -49,10 +58,20 @@ p_hsType' multilineArgs = \case
4958 _ -> return ()
5059 NotPromoted -> return ()
5160 p_rdrName n
52− HsAppTy NoExt 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
@@ -62,7 +81,7 @@ p_hsType' multilineArgs = \case
6281 inci $ do
6382 txt "@"
6483 located kd p_hsType
65− HsFunTy NoExt x y@(L _ y') -> do
84+ HsFunTy NoExtField x y@(L _ y') -> do
6685 located x p_hsType
6786 space
6887 txt "->"
@@ -70,44 +89,49 @@ p_hsType' multilineArgs = \case
7089 case y' of
7190 HsFunTy {} -> p_hsTypeR y'
7291 _ -> located y p_hsTypeR
73− HsListTy NoExt t ->
92+ HsListTy NoExtField t ->
7493 located t (brackets N . p_hsType)
75− HsTupleTy NoExt tsort xs ->
94+ HsTupleTy NoExtField tsort xs ->
7695 let parens' =
7796 case tsort of
7897 HsUnboxedTuple -> parensHash N
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
84− HsSumTy NoExt xs ->
85− parensHash N . sitcc $
101+ in parens' $ sep commaDel (sitcc . located' p_hsType) xs
102+ HsSumTy NoExtField xs ->
103+ parensHash N $
86104 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
87− HsOpTy NoExt x op y ->
105+ HsOpTy NoExtField x op y ->
88106 sitcc $
89107 let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
90108 in p_tyOpTree (reassociateOpTree Just opTree)
91− HsParTy NoExt t ->
109+ HsParTy NoExtField t ->
92110 parens N (located t p_hsType)
93− HsIParamTy NoExt n t -> sitcc $ do
111+ HsIParamTy NoExtField n t -> sitcc $ do
94112 located n atom
95113 space
96114 txt "::"
97115 breakpoint
98116 inci (located t p_hsType)
99− HsStarTy NoExt _ -> txt "*"
100− HsKindSig NoExt t k -> sitcc $ do
117+ HsStarTy NoExtField _ -> txt "*"
118+ 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)
106− HsSpliceTy NoExt splice -> p_hsSplice splice
107− HsDocTy NoExt t str -> do
108− p_hsDocString Pipe True str
109− located t p_hsType
110− HsBangTy NoExt (HsSrcBang _ u s) t -> do
124+ HsSpliceTy NoExtField splice -> p_hsSplice splice
125+ HsDocTy NoExtField t str ->
126+ case docStyle of
127+ PipeStyle -> do
128+ p_hsDocString Pipe True str
129+ located t p_hsType
130+ CaretStyle -> do
131+ located t p_hsType
132+ newline
133+ p_hsDocString Caret False str
134+ HsBangTy NoExtField (HsSrcBang _ u s) t -> do
111135 case u of
112136 SrcUnpack -> txt "{-# UNPACK #-}" >> space
113137 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
@@ -117,9 +141,9 @@ p_hsType' multilineArgs = \case
117141 SrcStrict -> txt "!"
118142 NoSrcStrict -> return ()
119143 located t p_hsType
120− HsRecTy NoExt fields ->
144+ HsRecTy NoExtField fields ->
121145 p_conDeclFields fields
122− HsExplicitListTy NoExt p xs -> do
146+ HsExplicitListTy NoExtField p xs -> do
123147 case p of
124148 IsPromoted -> txt "'"
125149 NotPromoted -> return ()
@@ -129,31 +153,31 @@ 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
133− HsExplicitTupleTy NoExt xs -> do
156+ sep commaDel (sitcc . located' p_hsType) xs
157+ 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
140− HsTyLit NoExt t ->
163+ sep commaDel (located' p_hsType) xs
164+ HsTyLit NoExtField t ->
141165 case t of
142166 HsStrTy (SourceText s) _ -> p_stringLit s
143167 a -> atom a
144− HsWildCardTy NoExt -> txt "_"
168+ HsWildCardTy NoExtField -> txt "_"
145169 XHsType (NHsCoreTy t) -> atom t
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,54 +191,54 @@ 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
176− UserTyVar NoExt x ->
198+ UserTyVar NoExtField x ->
177199 p_rdrName x
178− KindedTyVar NoExt l k -> parens N $ do
200+ KindedTyVar NoExtField l k -> parens N $ do
179201 located l atom
180202 space
181203 txt "::"
182204 breakpoint
183205 inci (located k p_hsType)
184− XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
206+ XTyVarBndr x -> noExtCon x
185207
186208-- | Render several @forall@-ed variables.
187−p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()
188−p_forallBndrs _ [] = txt "forall."
189−p_forallBndrs p tyvars =
209+p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
210+p_forallBndrs ForallInvis _ [] = txt "forall."
211+p_forallBndrs ForallVis _ [] = txt "forall ->"
212+p_forallBndrs vis p tyvars =
190213 switchLayout (getLoc <$> tyvars) $ do
191214 txt "forall"
192215 breakpoint
193216 inci $ do
194217 sitcc $ sep breakpoint (sitcc . located' p) tyvars
195− txt "."
218+ case vis of
219+ ForallInvis -> txt "."
220+ ForallVis -> space >> txt "->"
196221
197222p_conDeclFields :: [LConDeclField GhcPs] -> R ()
198223p_conDeclFields xs =
199− braces N . sitcc $
200− sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
224+ braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
201225
202226p_conDeclField :: ConDeclField GhcPs -> R ()
203227p_conDeclField ConDeclField {..} = do
204228 mapM_ (p_hsDocString Pipe True) cd_fld_doc
205229 sitcc $
206230 sep
207− (comma >> breakpoint)
231+ commaDel
208232 (located' (p_rdrName . rdrNameFieldOcc))
209233 cd_fld_names
210234 space
211235 txt "::"
212236 breakpoint
213237 sitcc . inci $ p_hsType (unLoc cd_fld_type)
214−p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"
238+p_conDeclField (XConDeclField x) = noExtCon x
215239
216240tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
217−tyOpTree (L _ (HsOpTy NoExt l op r)) =
241+tyOpTree (L _ (HsOpTy NoExtField l op r)) =
218242 OpBranch (tyOpTree l) op (tyOpTree r)
219243tyOpTree n = OpNode n
220244
@@ -235,17 +259,17 @@ p_tyOpTree (OpBranch l op r) = do
235259tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
236260tyVarsToTypes = \case
237261 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
238− XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
262+ XLHsQTyVars x -> noExtCon x
239263
240264tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
241265tyVarToType = \case
242− UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
243− KindedTyVar NoExt tvar kind ->
266+ UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
267+ KindedTyVar NoExtField tvar kind ->
244268 -- Note: we always add parentheses because for whatever reason GHC does
245269 -- not use HsParTy for left-hand sides of declarations. Please see
246270 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
247271 -- long as 'tyVarToType' does not get applied to right-hand sides of
248272 -- declarations.
249− HsParTy NoExt $ noLoc $
250− HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
251− XTyVarBndr {} -> notImplemented "XTyVarBndr"
273+ HsParTy NoExtField . noLoc $
274+ HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
275+ XTyVarBndr x -> noExtCon x
src/Ormolu/Printer/Operators.hs+51−68
@@ -10,15 +10,14 @@ module Ormolu.Printer.Operators
1010 )
1111where
1212
13−import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)
1413import Data.Function (on)
15−import Data.List
14+import qualified Data.List as L
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as M
1617import Data.Maybe (fromMaybe, mapMaybe)
17−import Data.Ord (Down (Down), comparing)
1818import GHC
19−import OccName (mkVarOcc)
20−import RdrName (mkRdrUnqual)
21−import SrcLoc (combineSrcSpans)
19+import OccName (occNameString)
20+import Ormolu.Utils (unSrcSpan)
2221
2322-- | Intermediate representation of operator trees. It has two type
2423-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
@@ -58,7 +57,7 @@ reassociateOpTree getOpName opTree =
5857reassociateOpTreeWith ::
5958 forall ty op.
6059 -- | Fixity map for operators
61− [(RdrName, Fixity)] ->
60+ Map String Fixity ->
6261 -- | How to get the name of an operator
6362 (op -> Maybe RdrName) ->
6463 -- | Original 'OpTree'
@@ -69,13 +68,13 @@ reassociateOpTreeWith fixityMap getOpName = go
6968 where
7069 fixityOf :: op -> Fixity
7170 fixityOf op = fromMaybe defaultFixity $ do
72− opName <- getOpName op
73− lookup opName fixityMap
71+ s <- occNameString . rdrNameOcc <$> getOpName op
72+ M.lookup s fixityMap
7473 -- Here, left branch is already associated and the root alongside with
7574 -- the right branch is right-associated. This function picks up one item
7675 -- from the right and inserts it correctly to the left.
7776 --
78− -- Also, we are using the 'compareFixity' function which returns if the
77+ -- Also, we are using the 'compareFixity' function which tells if the
7978 -- expression should associate to right.
8079 go :: OpTree ty op -> OpTree ty op
8180 -- base cases
@@ -95,6 +94,16 @@ reassociateOpTreeWith fixityMap getOpName = go
9594 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
9695 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
9796
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+
98107-- | Build a map of inferred 'Fixity's from an 'OpTree'.
99108buildFixityMap ::
100109 forall ty op.
@@ -103,23 +112,26 @@ buildFixityMap ::
103112 -- | Operator tree
104113 OpTree (Located ty) (Located op) ->
105114 -- | Fixity map
106− [(RdrName, Fixity)]
115+ Map String Fixity
107116buildFixityMap getOpName opTree =
108− concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
109− . zip [0 ..]
110− . groupBy (doubleWithinEps 0.00001 `on` snd)
111− . (overrides ++)
112− . 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
113123 $ score opTree
114124 where
115− -- Add a special case for ($), since it is pretty unlikely for someone
116− -- to override it.
117− overrides :: [(RdrName, Double)]
118− overrides =
119− [ (mkRdrUnqual $ mkVarOcc "$", -1)
120− ]
121− -- Assign scores to operators based on their location in the source.
122− 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)]
123135 score (OpNode _) = []
124136 score (OpBranch l o r) = fromMaybe (score r) $ do
125137 -- If we fail to get any of these, 'defaultFixity' will be used by
@@ -129,50 +141,27 @@ buildFixityMap getOpName opTree =
129141 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
130142 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
131143 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
132− opName <- getOpName (unLoc o)
144+ opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
133145 let s
134− | le < ob =
135− -- if the operator is in the beginning of a line, assign
136− -- a score relative to its column within range [0, 1).
137− fromIntegral oc / fromIntegral (maxCol + 1)
138− | oe < rb =
139− -- if the operator is in the end of the line, assign the
140− -- score 1.
141− 1
142− | otherwise =
143− 2 -- otherwise, assign a high score.
146+ | le < ob = AtBeginning oc
147+ | oe < rb = AtEnd
148+ | otherwise = InBetween
144149 return $ (opName, s) : score r
145− -- Pick the most common score per 'RdrName'.
146− modeScores :: [(RdrName, Double)] -> [(RdrName, Double)]
147− modeScores =
148− sortOn snd
150+ selectScores :: [(String, Score)] -> [(String, Score)]
151+ selectScores =
152+ L.sortOn snd
149153 . mapMaybe
150154 ( \case
151155 [] -> Nothing
152− xs@((n, _) : _) -> Just (n, mode $ map snd xs)
156+ xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)
153157 )
154− . groupBy ((==) `on` fst)
155− . sort
156− -- Return the most common number, leaning to the smaller
157− -- one in case of a tie.
158− mode :: [Double] -> Double
159− mode =
160− head
161− . minimumBy (comparing (Down . length))
162− . groupBy (doubleWithinEps 0.0001)
163− . sort
164− -- The start column of the rightmost operator.
165− maxCol = go opTree
166− where
167− go (OpNode (L _ _)) = 0
168− go (OpBranch l (L o _) r) =
169− maximum
170− [ go l,
171− maybe 0 srcSpanStartCol (unSrcSpan o),
172− go r
173− ]
174− unSrcSpan (RealSrcSpan r) = Just r
175− unSrcSpan (UnhelpfulSpan _) = Nothing
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'
176165
177166----------------------------------------------------------------------------
178167-- Helpers
@@ -186,9 +175,3 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =
186175 OpBranch (OpNode l) lop (normalizeOpTree r)
187176normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
188177 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
189−
190−fixity :: Int -> FixityDirection -> Fixity
191−fixity = Fixity NoSourceText
192−
193−doubleWithinEps :: Double -> Double -> Double -> Bool
194−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+83−9
@@ -1,41 +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,
14+ unSrcSpan,
15+ incSpanLine,
16+ separatedByBlank,
17+ separatedByBlankNE,
18+ onTheSameLine,
19+ removeIndentation,
1220 )
1321where
1422
15−import Data.Data (Data, showConstr, toConstr)
23+import Data.Char (isSpace)
1624import Data.List (dropWhileEnd)
1725import Data.List.NonEmpty (NonEmpty (..))
26+import qualified Data.List.NonEmpty as NE
27+import Data.Maybe (fromMaybe)
1828import Data.Text (Text)
1929import qualified Data.Text as T
2030import GHC
21−import HsDoc (HsDocString, unpackHDS)
31+import GHC.DynFlags (baseDynFlags)
2232import qualified Outputable as GHC
2333
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+
2453-- | Combine all source spans from the given list.
2554combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
2655combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
2756
28−-- | Return 'True' if given element of AST is module.
29−isModule :: Data a => a -> Bool
30−isModule x = showConstr (toConstr x) == "HsModule"
31−
3257-- | Placeholder for things that are not yet implemented.
3358notImplemented :: String -> a
3459notImplemented msg = error $ "not implemented yet: " ++ msg
3560
3661-- | Pretty-print an 'GHC.Outputable' thing.
3762showOutputable :: GHC.Outputable o => o -> String
38−showOutputable = GHC.showSDocUnsafe . GHC.ppr
63+showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
3964
4065-- | Split and normalize a doc string. The result is a list of lines that
4166-- make up the comment.
@@ -74,8 +99,57 @@ splitDocString docStr =
7499 then dropSpace <$> xs
75100 else xs
76101
102+-- | Get 'LHsType' out of 'LHsTypeArg'.
77103typeArgToType :: LHsTypeArg p -> LHsType p
78104typeArgToType = \case
79105 HsValArg tm -> tm
80106 HsTypeArg _ ty -> ty
81107 HsArgPar _ -> notImplemented "HsArgPar"
108+
109+-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
110+unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
111+unSrcSpan = \case
112+ RealSrcSpan r -> Just r
113+ UnhelpfulSpan _ -> Nothing
114+
115+-- | Increment line number in a 'SrcSpan'.
116+incSpanLine :: Int -> SrcSpan -> SrcSpan
117+incSpanLine i = \case
118+ RealSrcSpan s ->
119+ let start = realSrcSpanStart s
120+ end = realSrcSpanEnd s
121+ incLine x =
122+ let file = srcLocFile x
123+ line = srcLocLine x
124+ col = srcLocCol x
125+ in mkRealSrcLoc file (line + i) col
126+ in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end))
127+ UnhelpfulSpan x -> UnhelpfulSpan x
128+
129+-- | Do two declarations have a blank between them?
130+separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
131+separatedByBlank loc a b =
132+ fromMaybe False $ do
133+ endA <- srcSpanEndLine <$> unSrcSpan (loc a)
134+ startB <- srcSpanStartLine <$> unSrcSpan (loc b)
135+ pure (startB - endA >= 2)
136+
137+-- | Do two declaration groups have a blank between them?
138+separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
139+separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
140+
141+-- | Return 'True' if one span ends on the same line the second one starts.
142+onTheSameLine :: SrcSpan -> SrcSpan -> Bool
143+onTheSameLine a b =
144+ isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))
145+
146+-- | Remove indentation from a given 'String'. Return the input with
147+-- indentation removed and the detected indentation level.
148+removeIndentation :: String -> (String, Int)
149+removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)
150+ where
151+ n = minimum (getIndent <$> xs)
152+ getIndent y =
153+ if all isSpace y
154+ then 0
155+ else length (takeWhile isSpace y)
tests/Ormolu/PrinterSpec.hs+7−10
@@ -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
@@ -15,7 +12,7 @@ import qualified Data.Text.IO as T
1512import Ormolu
1613import Path
1714import Path.IO
18−import System.FilePath (addExtension, dropExtensions, splitExtensions)
15+import qualified System.FilePath as F
1916import Test.Hspec
2017
2118spec :: Spec
@@ -53,19 +50,19 @@ locateExamples =
5350isInput :: Path Rel File -> Bool
5451isInput path =
5552 let s = fromRelFile path
56− (s', exts) = splitExtensions s
53+ (s', exts) = F.splitExtensions s
5754 in exts == ".hs" && not ("-out" `isSuffixOf` s')
5855
5956-- | For given path of input file return expected name of output.
6057deriveOutput :: Path Rel File -> IO (Path Rel File)
6158deriveOutput path =
6259 parseRelFile $
63− addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
60+ F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs"
6461
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