git.iko.soy/ormolu
on b08af17 help sign in
dec158c
swap
0 ahead, 138 behind
344 files changed+2230−5107
since splitsnapshots
unifiedsplit
.buildkite/pipeline.yml−18 .circleci/config.yml+49 .github/workflows/binaries.yml−39 .github/workflows/build.sh−7 .gitignore−1 CHANGELOG.md−214 CONTRIBUTING.md+1−1 DESIGN.md+11−11 README.md+13−57 app/Main.hs+95−133 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+4−2 data/examples/declaration/class/functional-dependencies-out.hs+1−2 data/examples/declaration/class/multi-parameters2-out.hs+3−2 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/class/type-operators3-out.hs+1−1 data/examples/declaration/data/existential-multiline-out.hs−12 data/examples/declaration/data/existential-multiline.hs−7 data/examples/declaration/data/field-layout/gadt-out.hs+1−2 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+20−19 data/examples/declaration/data/simple-broken-out.hs+2−1 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+2−4 data/examples/declaration/instance/data-family-instances-newtype-out.hs+4−3 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+5−6 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/application-1-out.hs−19 data/examples/declaration/value/function/application-1.hs−14 data/examples/declaration/value/function/application-0-out.hs → data/examples/declaration/value/function/application-out.hs data/examples/declaration/value/function/application-0.hs → data/examples/declaration/value/function/application.hs 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+5−6 data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+14−18 data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs+2−3 data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs+7−9 data/examples/declaration/value/function/arrow/proc-forms1-out.hs+6−8 data/examples/declaration/value/function/arrow/proc-forms2-out.hs+6−10 data/examples/declaration/value/function/arrow/proc-forms2.hs+6−6 data/examples/declaration/value/function/arrow/proc-ifs-out.hs+4−6 data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+4−5 data/examples/declaration/value/function/arrow/recursive-procs-out.hs+10−14 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/block-arguments-out.hs−5 data/examples/declaration/value/function/block-arguments.hs−5 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−7 data/examples/declaration/value/function/infix/dollar-chains.hs−4 data/examples/declaration/value/function/infix/hanging-out.hs+3−4 data/examples/declaration/value/function/infix/lenses-out.hs+7−8 data/examples/declaration/value/function/let-single-line-out.hs+1 data/examples/declaration/value/function/list-notation-0-out.hs−5 data/examples/declaration/value/function/list-notation-0.hs−5 data/examples/declaration/value/function/list-notation-1-out.hs−8 data/examples/declaration/value/function/list-notation-1.hs−7 data/examples/declaration/value/function/list-notation-2-out.hs−6 data/examples/declaration/value/function/list-notation-2.hs−5 data/examples/declaration/value/function/list-notation-3-out.hs−12 data/examples/declaration/value/function/list-notation-3.hs−10 data/examples/declaration/value/function/multi-way-if-out.hs+4−10 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-0-out.hs−5 data/examples/declaration/value/function/operators-0.hs−4 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+9−11 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.hs → data/examples/declaration/value/function/record-constructors.hs data/examples/declaration/value/function/record/updaters-out.hs → data/examples/declaration/value/function/record-updaters-out.hs data/examples/declaration/value/function/record/updaters.hs → data/examples/declaration/value/function/record-updaters.hs data/examples/declaration/value/function/record/wildcards-out.hs → data/examples/declaration/value/function/record-wildcards-out.hs+6−7 data/examples/declaration/value/function/record/wildcards.hs → data/examples/declaration/value/function/record-wildcards.hs data/examples/declaration/value/function/record/constructors-out.hs−31 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/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+2−3 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+3−2 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+6−1 data/examples/module-header/multiline2.hs+2−2 data/examples/module-header/preceding-comment-with-haddock-out.hs+4−1 data/examples/module-header/shebang-out.hs−1 data/examples/module-header/shebang-with-pragmas-out.hs−5 data/examples/module-header/shebang-with-pragmas.hs−5 data/examples/module-header/shebang.hs−1 data/examples/module-header/singleline-empty-out.hs+4−1 data/examples/module-header/stack-header-0-out.hs−7 data/examples/module-header/stack-header-0.hs−4 data/examples/module-header/stack-header-1-out.hs−8 data/examples/module-header/stack-header-1.hs−5 data/examples/module-header/stack-header-2-out.hs−12 data/examples/module-header/stack-header-2.hs−12 data/examples/module-header/warning-pragma-multiline-out.hs+4−1 data/examples/module-header/warning-pragma-out.hs+1−3 data/examples/other/argument-comment-out.hs+1 data/examples/other/comment-after-preceding-haddock-out.hs−12 data/examples/other/comment-after-preceding-haddock.hs−12 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/empty-forall-out.hs−18 data/examples/other/empty-forall.hs−17 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+2−1 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+4−1 data/examples/other/pragma-sorting-out.hs−11 data/examples/other/pragma-sorting.hs−10 default.nix+50−108 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+3−6 nix/nixpkgs/default.nix+3−7 nix/ormolize/default.nix+13−29 nix/ormolize/ormolize.sh+17 ormolu.cabal+155−174 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+2−4 src/GHC.hs+13−2 src/GHC/DynFlags.hs+20−33 src/Ormolu.hs+19−19 src/Ormolu/Config.hs+29−65 src/Ormolu/Diff.hs+17−25 src/Ormolu/Exception.hs+19−24 src/Ormolu/Imports.hs+51−172 src/Ormolu/Parser.hs+68−99 src/Ormolu/Parser/CommentStream.hs+64−152 src/Ormolu/Parser/Pragma.hs+5−5 src/Ormolu/Parser/Result.hs+11−26 src/Ormolu/Parser/Shebang.hs−27 src/Ormolu/Printer.hs+7−17 src/Ormolu/Printer/Combinators.hs+54−39 src/Ormolu/Printer/Comments.hs+78−69 src/Ormolu/Printer/Internal.hs+109−173 src/Ormolu/Printer/Meat/Common.hs+18−20 src/Ormolu/Printer/Meat/Declaration.hs+110−175 src/Ormolu/Printer/Meat/Declaration.hs-boot+3−2 src/Ormolu/Printer/Meat/Declaration/Annotation.hs+3−2 src/Ormolu/Printer/Meat/Declaration/Class.hs+38−26 src/Ormolu/Printer/Meat/Declaration/Data.hs+47−74 src/Ormolu/Printer/Meat/Declaration/Default.hs+5−4 src/Ormolu/Printer/Meat/Declaration/Foreign.hs+3−2 src/Ormolu/Printer/Meat/Declaration/Instance.hs+27−21 src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+6−2 src/Ormolu/Printer/Meat/Declaration/Rule.hs+16−21 src/Ormolu/Printer/Meat/Declaration/Signature.hs+33−49 src/Ormolu/Printer/Meat/Declaration/Splice.hs+3−2 src/Ormolu/Printer/Meat/Declaration/Type.hs+8−8 src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+28−27 src/Ormolu/Printer/Meat/Declaration/Value.hs+357−435 src/Ormolu/Printer/Meat/Declaration/Value.hs-boot+4 src/Ormolu/Printer/Meat/Declaration/Warning.hs+10−8 src/Ormolu/Printer/Meat/ImportExport.hs+36−45 src/Ormolu/Printer/Meat/Module.hs+15−35 src/Ormolu/Printer/Meat/Pragma.hs+13−67 src/Ormolu/Printer/Meat/Type.hs+68−93 src/Ormolu/Printer/Operators.hs+62−57 src/Ormolu/Printer/SpanStream.hs+1−1 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+9−83 tests/Ormolu/Parser/PragmaSpec.hs+1−1 tests/Ormolu/PrinterSpec.hs+10−7
.buildkite/pipeline.ymldeleted−18
@@ -1,18 +0,0 @@
1−steps:
2− - label: Build and test with GHC 8.6.5
3− command: |
4− nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc865
5− timeout: 100
6− - label: Build and test with GHC 8.8.4
7− command: |
8− nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc884
9− timeout: 100
10− - label: Build and test with GHC 8.10.1
11− command: |
12− nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc8101
13− timeout: 100
14− - wait
15− - label: Check formatting
16− command: |
17− ./format.sh
18− git diff --exit-code --color=always
.circleci/config.ymlnew file+49
@@ -0,0 +1,49 @@
1+version: 2
2+
3+jobs:
4+ build:
5+ docker:
6+ - image: nixos/nix:2.1.3
7+ steps:
8+ - checkout
9+ - run:
10+ name: Add ca-certificates
11+ command: |
12+ apk --no-progress update
13+ apk --no-progress add ca-certificates
14+ - run:
15+ name: Setup Cachix
16+ command: |
17+ nix-env -iA cachix -f https://cachix.org/api/v1/install
18+ USER=dummy cachix use tweag
19+ - run:
20+ name: Build environment
21+ command: |
22+ nix-shell --pure --run :
23+ - run:
24+ name: Push Cachix
25+ command: |
26+ if [ -n "$CACHIX_SIGNING_KEY" ];
27+ then nix-store -qR --include-outputs $(nix-instantiate default.nix) | cachix push tweag;
28+ fi
29+ - run:
30+ name: Build the package (includes running the tests)
31+ command: nix-build --keep-going
32+ - run:
33+ name: Check formatting
34+ command: |
35+ ./format.sh
36+ nix-shell -p "(import ./nix/nixpkgs/default.nix).git" --command "git diff --exit-code --color=always"
37+ - run:
38+ name: Generate Haddocks
39+ command: nix-build --attr ormolu.doc
40+ - store_artifacts:
41+ path: result-doc/share/doc
42+ destination: haddock
43+
44+workflows:
45+ version: 2
46+ build:
47+ jobs:
48+ - build:
49+ context: org-global
.github/workflows/binaries.ymldeleted−39
@@ -1,39 +0,0 @@
1−name: Build binaries
2−on:
3− release:
4− types: [published]
5−jobs:
6− build:
7− strategy:
8− fail-fast: false
9− matrix:
10− os: [ubuntu-latest, macOS-latest, windows-latest]
11− runs-on: ${{ matrix.os }}
12− steps:
13− - uses: actions/checkout@v2
14− - uses: actions/setup-haskell@v1
15− if: runner.os != 'Linux'
16− with:
17− ghc-version: '8.10.1'
18− cabal-version: '3.2'
19− - name: Build Linux binary
20− if: runner.os == 'Linux'
21− run: |
22− docker run \
23− -v $(pwd):/mnt -w /mnt \
24− utdemir/ghc-musl:v14-ghc8101 \
25− bash .github/workflows/build.sh
26− - name: Build ${{ runner.os }} binary
27− if: runner.os != 'Linux'
28− shell: bash
29− run: |
30− cabal build exe:ormolu
31− cp $(find dist-newstyle \( -name ormolu -o -name ormolu.exe \) -type f) ormolu
32− - uses: actions/upload-release-asset@v1
33− env:
34− GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
35− with:
36− upload_url: ${{ github.event.release.upload_url }}
37− asset_path: ormolu
38− asset_name: ormolu-${{ runner.os }}
39− asset_content_type: application/octet-stream
.github/workflows/build.shdeleted−7
@@ -1,7 +0,0 @@
1−set -e
2−
3−cabal update
4−cabal build exe:ormolu --enable-executable-static --ghc-options="-split-sections"
5−
6−cp $(find dist-newstyle -name ormolu -type f) .
7−strip -s ormolu
.gitignore−1
@@ -26,5 +26,4 @@ cabal.sandbox.config
2626dist-*/
2727dist/
2828stack.yaml
29−stack.yaml.lock
3029result*
CHANGELOG.md−214
@@ -1,198 +1,10 @@
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−
163−* Fixed an issue related to unnecessary use of curly braces. [Issue
164− 473](https://github.com/tweag/ormolu/issues/473).
165−
166−* Fixed the issue with formatting multi-way if when it happens to be a
167− function applied to arguments [Issue
168− 488](https://github.com/tweag/ormolu/issues/488). This changed the way
169− multi-line if is formatted in general.
170−
171−* Added support for record dot pre-processor when used via the plugin.
172− [Issue 486](https://github.com/tweag/ormolu/issues/486).
173−
174−* Stopped hanging record constructors and improved placing
175− potentially-hanging consturctions in the presence of comments. [Issue
176− 447](https://github.com/tweag/ormolu/issues/447).
177−
178−* Fixed indentation in presence of type applications. [Issue
179− 493](https://github.com/tweag/ormolu/issues/493).
180−
181−* Class and instance declarations now do not have a blank line after
182− `where`. Grouping of methods from the original input is also preserved
183− with some normalizations. [Issue
184− 431](https://github.com/tweag/ormolu/issues/431).
185−
186−## Ormolu 0.0.2.0
187−
1883* Switched to `ghc-lib-parser` instead of depending on the `ghc` package
1894 directly. This should allow us to use newest features of GHC while not
1905 necessarily depending on the newest version of the compiler. In addition
1916 to that Ormolu is now GHCJS-compatible.
1927
193−* Now unrecognized GHC options passed with `--ghc-opt` cause Ormolu to fail
194− (exit code 7).
195−
1968* Fixed formatting of result type in closed type families. See [issue
1979 420](https://github.com/tweag/ormolu/issues/420).
19810
@@ -203,32 +15,6 @@
20315 inside the export list. See [issue
20416 430](https://github.com/tweag/ormolu/issues/430).
20517
206−* Empty `forall`s are now correctly preserved. See [issue
207− 429](https://github.com/tweag/ormolu/issues/429).
208−
209−* Fixed [issue 446](https://github.com/tweag/ormolu/issues/446), which
210− involved braces and operators.
211−
212−* When there are comments between preceding Haddock (pipe-style) and its
213− corresponding declaration they are preserved like this in the output
214− instead of being shifted. To be clear, this is not a very good idea to
215− have comments in that position because the Haddock will end up not being
216− associated with the declarations. Issues
217− [440](https://github.com/tweag/ormolu/issues/440) and
218− [448](https://github.com/tweag/ormolu/issues/448).
219−
220−* Implemented correct handling of shebangs. [Issue
221− 377](https://github.com/tweag/ormolu/issues/377).
222−
223−* Implemented correct handling of stack headers. [Issue
224− 393](https://github.com/tweag/ormolu/issues/393).
225−
226−* Sorting language pragmas cannot not change meaning of the input program
227− anymore. [Issue 404](https://github.com/tweag/ormolu/issues/404).
228−
229−* Fixed formatting of applications where function is a complex expression.
230− [Issue 444](https://github.com/tweag/ormolu/issues/444).
231−
23218## Ormolu 0.0.1.0
23319
23420* Initial release.
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−* Idempotence property is verified: formatting already formatted code
33+* Idempotency 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 when no CPP is used;
27+* Preserve the meaning of the formatted functions;
2828* Make reasonable use of screen space;
2929* Use linear space and computation time on the size of the input;
3030* Preserve comments;
@@ -140,10 +140,8 @@ impossible to guess what they'll be called on.
140140
141141### CPP
142142
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.
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.
147145
148146There are the following challenges when formatting a module with CPP:
149147
@@ -182,15 +180,14 @@ True
182180```
183181
184182At the time of this writing, formatting this program with Hindent
185−or Ormolu produces the same output we would get if the CPP directives
186−were considered comments:
183+produces the same output we would get if the CPP directives were
184+considered comments:
187185
188186```
189−$ ormolu --version
190−ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115
191−using ghc-lib-parser 8.10.1.20200412
187+$ hindent --version
188+hindent 5.2.7
192189
193−$ ormolu --mode inplace test.hs
190+$ hindent test.hs
194191
195192$ cat test.hs
196193{-# LANGUAGE CPP #-}
@@ -230,6 +227,9 @@ to parse Haskell modules. If CPP is replaced with some language
230227extension or mechanism to do conditional compilation, all tools
231228will benefit from it.
232229
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+13−57
@@ -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−[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu)
7+[![CircleCI](https://circleci.com/gh/tweag/ormolu/tree/master.svg?style=svg&circle-token=cfd37a39265561eb44e608f97cf953cb2a394c03)](https://circleci.com/gh/tweag/ormolu/tree/master)
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 accommodate them.
25+ extensions enter broad use, we may change the style to accomodate 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,12 +45,11 @@ Alternatively, `stack` could be used with a `stack.yaml` file as follows.
4545
4646```console
4747$ cat stack.yaml
48−resolver: lts-16.0
48+resolver: lts-14.3
4949packages:
5050- '.'
5151
52−$ stack build # to build
53−$ stack install # to install
52+$ stack build
5453```
5554
5655To use Ormolu directly from GitHub with Nix, this snippet may come in handy:
@@ -92,44 +91,20 @@ formatted output.
9291$ ormolu --mode inplace Module.hs
9392```
9493
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−
12294## Current limitations
12395
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.
96+* Does not handle CPP (wontfix, see [the design document][design]).
12997* Input modules should be parsable by Haddock, which is a bit stricter
13098 criterion than just being valid Haskell modules.
13199* Various minor idempotence issues, most of them are related to comments.
132100
101+## Editor integration
102+
103+We know of the following editor integrations:
104+
105+* [Emacs][emacs-package]
106+* [VS Code][vs-code-plugin]
107+
133108## Running on Hackage
134109
135110It's possible to try Ormolu on arbitrary packages from Hackage. For that
@@ -144,22 +119,6 @@ also contain formatted `.hs` files for inspection and original inputs with
144119`.hs-original` extension (those are with CPP dropped, exactly what is fed
145120into Ormolu).
146121
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−
163122## Contributing
164123
165124See [CONTRIBUTING.md][contributing].
@@ -170,12 +129,9 @@ See [LICENSE.md][license].
170129
171130Copyright © 2018–present Tweag I/O
172131
173−[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
132+[design]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
174133[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md
175134[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md
176135[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
177136[emacs-package]: https://github.com/vyorkin/ormolu.el
178137[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+95−133
@@ -1,17 +1,12 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeApplications #-}
65
76module Main (main) where
87
9−import Control.Exception (SomeException, displayException, try)
108import Control.Monad
11−import Data.Bool (bool)
12−import Data.Either (lefts)
139import Data.List (intercalate, sort)
14−import qualified Data.Text.IO as TIO
1510import Data.Version (showVersion)
1611import Development.GitRev
1712import Options.Applicative
@@ -21,8 +16,10 @@ import Ormolu.Utils (showOutputable)
2116import Paths_ormolu (version)
2217import System.Exit (ExitCode (..), exitWith)
2318import System.IO (hPutStrLn, stderr)
19+import qualified Data.Text.IO as TIO
2420
2521-- | Entry point of the program.
22+
2623main :: IO ()
2724main = withPrettyOrmoluExceptions $ do
2825 Opts {..} <- execParser optsParserInfo
@@ -30,50 +27,35 @@ main = withPrettyOrmoluExceptions $ do
3027 case optInputFiles of
3128 [] -> formatOne' Nothing
3229 ["-"] -> formatOne' Nothing
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)
30+ xs -> mapM_ (formatOne' . Just) xs
4231
4332-- | Format a single input.
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 ()
33+
34+formatOne
35+ :: Mode -- ^ Mode of operation
36+ -> Config -- ^ Configuration
37+ -> Maybe FilePath -- ^ File to format or stdin as 'Nothing'
38+ -> IO ()
5239formatOne mode config = \case
5340 Nothing -> do
5441 r <- ormoluStdin config
5542 case mode of
5643 Stdout -> TIO.putStr r
57− _ -> do
58− hPutStrLn
59− stderr
44+ _ -> do
45+ hPutStrLn stderr
6046 "This feature is not supported when input comes from stdin."
61− -- 101 is different from all the other exit codes we already use.
47+ -- 101 is different from all the other exit codes we already use.
6248 exitWith (ExitFailure 101)
6349 Just inputFile -> do
64− originalInput <- TIO.readFile inputFile
65− formattedInput <- ormoluFile config inputFile
50+ r <- ormoluFile config inputFile
6651 case mode of
6752 Stdout ->
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
53+ TIO.putStr r
54+ InPlace ->
55+ TIO.writeFile inputFile r
7556 Check -> do
76− when (formattedInput /= originalInput) $
57+ r' <- TIO.readFile inputFile
58+ when (r /= r') $
7759 -- 100 is different to all the other exit code that are emitted
7860 -- either from an 'OrmoluException' or from 'error' and
7961 -- 'notImplemented'.
@@ -83,121 +65,101 @@ formatOne mode config = \case
8365-- Command line options parsing.
8466
8567data Opts = Opts
86− { -- | Mode of operation
87− optMode :: !Mode,
88− -- | Ormolu 'Config'
89− optConfig :: !(Config RegionIndices),
90− -- | Haskell source files to format or stdin (when the list is empty)
91− optInputFiles :: ![FilePath]
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)
9274 }
9375
9476-- | Mode of operation.
77+
9578data Mode
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
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
10383 deriving (Eq, Show)
10484
10585optsParserInfo :: ParserInfo Opts
106−optsParserInfo =
107− info (helper <*> ver <*> exts <*> optsParser) . mconcat $
108− [ fullDesc,
109− progDesc "",
110− header ""
111− ]
86+optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $
87+ [ fullDesc
88+ , progDesc ""
89+ , header ""
90+ ]
11291 where
11392 ver :: Parser (a -> a)
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
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
130104 ]
105+ , "using ghc-lib-parser " ++ VERSION_ghc_lib_parser
106+ ]
131107 exts :: Parser (a -> a)
132− exts =
133− infoOption displayExts . mconcat $
134− [ long "manual-exts",
135− help "Display extensions that need to be enabled manually"
136− ]
108+ exts = infoOption displayExts . mconcat $
109+ [ long "manual-exts"
110+ , help "Display extensions that need to be enabled manually"
111+ ]
137112 displayExts = unlines $ sort (showOutputable <$> manualExts)
138113
139114optsParser :: Parser Opts
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− ]
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+ ]
159128
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− )
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+ ]
196157
197158----------------------------------------------------------------------------
198159-- Helpers
199160
200161-- | Parse 'Mode'.
162+
201163parseMode :: ReadM Mode
202164parseMode = eitherReader $ \case
203165 "stdout" -> Right Stdout
data/examples/declaration/annotation/annotation-out.hs−1
@@ -18,5 +18,4 @@ foo = 5
1818
1919data Foo = Foo Int
2020{-# ANN type Foo ("HLint: ignore") #-}
21−
2221{- Comment -}
data/examples/declaration/class/associated-data1-out.hs+1
@@ -4,6 +4,7 @@ class Foo a where data FooBar a
44
55-- | Something.
66class Bar a where
7+
78 -- | Bar bar
89 data BarBar a
910
data/examples/declaration/class/associated-data2-out.hs+1
@@ -4,6 +4,7 @@ module Main where
44
55-- | Something more.
66class Baz a where
7+
78 -- | Baz bar
89 data
910 BazBar
data/examples/declaration/class/associated-type-defaults-out.hs+2
@@ -4,6 +4,7 @@ class Foo a where type FooBar a = Int
44
55-- | Something.
66class Bar a where
7+
78 -- Define bar
89 type
910 BarBar a =
@@ -17,6 +18,7 @@ class Bar a where
1718 a
1819
1920class Baz a where
21+
2022 type
2123 BazBar
2224 a
data/examples/declaration/class/associated-types1-out.hs+1
@@ -4,6 +4,7 @@ class Foo a where type FooBar a
44
55-- | Something.
66class Bar a where
7+
78 -- | Bar bar
89 type BarBar a
910
data/examples/declaration/class/associated-types2-out.hs+1
@@ -4,6 +4,7 @@ module Main where
44
55-- | Something more.
66class Baz a where
7+
78 -- | Baz bar
89 type
910 BazBar
data/examples/declaration/class/default-implementations-comments-out.hs+1
@@ -2,6 +2,7 @@ module Main where
22
33-- | Baz
44class Baz a where
5+
56 foobar :: a -> a
67 foobar a =
78 barbaz (bazbar a)
data/examples/declaration/class/default-signatures-out.hs+2
@@ -4,11 +4,13 @@ module Main where
44
55-- | Something else.
66class Bar a where
7+
78 -- | Bar
89 bar ::
910 String ->
1011 String ->
1112 a
13+
1214 -- Pointless comment
1315 default bar ::
1416 ( Read a,
data/examples/declaration/class/default-signatures-simple-out.hs+2
@@ -2,7 +2,9 @@ module Main where
22
33-- | Something.
44class Foo a where
5+
56 -- | Foo
67 foo :: a -> String
8+
79 default foo :: Show a => a -> String
810 foo = show
data/examples/declaration/class/dependency-super-classes-out.hs+4−2
@@ -4,7 +4,9 @@ module Main where
44
55-- | Something.
66class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where
7+
78 get :: m s
9+
810 put :: s -> m ()
911
1012-- | 'MonadParsec'
@@ -13,8 +15,8 @@ class
1315 MonadPlus m -- Potential for failure
1416 ) =>
1517 MonadParsec e s m
16− | m -> e s
17− where
18+ | m -> e s where
19+
1820 -- | 'getState' returns state
1921 getState ::
2022 m s
data/examples/declaration/class/functional-dependencies-out.hs+1−2
@@ -14,6 +14,5 @@ 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
18− where
17+ a b d -> a b c d where
1918 baz :: a -> b
data/examples/declaration/class/multi-parameters2-out.hs+3−2
@@ -10,10 +10,11 @@ class
1010 c -- Baz bar
1111 d -- Baz baz
1212 e -- Rest
13− f
14− where
13+ f where
14+
1515 barbaz ::
1616 a -> f
17+
1718 bazbar ::
1819 e ->
1920 f
data/examples/declaration/class/newlines-after-where-out.hsdeleted−5
@@ -1,5 +0,0 @@
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.hsdeleted−7
@@ -1,7 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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.hsdeleted−13
@@ -1,13 +0,0 @@
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.hsdeleted−23
@@ -1,23 +0,0 @@
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.hsdeleted−19
@@ -1,19 +0,0 @@
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.hsdeleted−17
@@ -1,17 +0,0 @@
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.hsdeleted−15
@@ -1,15 +0,0 @@
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,6 +21,8 @@ class Baz a where
2121 a
2222
2323class BarBaz a where
24+
2425 barbaz ::
2526 a -> b
27+
2628 bazbar :: b -> a
data/examples/declaration/class/type-operators3-out.hs+1−1
@@ -1,7 +1,7 @@
1+{-# LANGUAGE NoStarIsType #-}
12{-# LANGUAGE PolyKinds #-}
23{-# LANGUAGE TypeFamilies #-}
34{-# LANGUAGE TypeOperators #-}
4−{-# LANGUAGE NoStarIsType #-}
55
66class PNum x where
77 type (a :: x) * (b :: x)
data/examples/declaration/data/existential-multiline-out.hs−12
@@ -3,15 +3,3 @@
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,10 +3,3 @@
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+1−2
@@ -6,6 +6,5 @@ data Foo a b where
66 Foo :: Foo Int Int
77 -- | Something else
88 Bar ::
9− Foo
10− Char
9+ Foo Char
1110 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 = Foo
5− { -- | Something
6− foo :: Foo Int Int,
7− -- | Something else
8− bar ::
9− Bar
10− Char
11− Char
12− }
4+data Foo
5+ = Foo
6+ { -- | Something
7+ foo :: Foo Int Int,
8+ -- | Something else
9+ bar ::
10+ Bar 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.hsdeleted−7
@@ -1,7 +0,0 @@
1−data
2− Foo
3− a
4− b
5− c
6− where
7− Foo :: a -> b -> c -> Foo a b c
data/examples/declaration/data/gadt/multiline-where.hsdeleted−6
@@ -1,6 +0,0 @@
1−data
2− Foo
3− a
4− b
5− c where
6− Foo :: a -> b -> c -> Foo a b c
data/examples/declaration/data/multiline-arg-parens-out.hs+1−1
@@ -5,6 +5,6 @@ data Foo
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.hsdeleted−5
@@ -1,5 +0,0 @@
1−data Optimisation
2− = PETransform
3− | -- | partial eval and associated transforms
4− GeneralisedNatHack
5− deriving (Show, Eq, Generic)
data/examples/declaration/data/partly-documented.hsdeleted−2
@@ -1,2 +0,0 @@
1−data Optimisation = PETransform | GeneralisedNatHack -- ^ partial eval and associated transforms
2− deriving (Show, Eq, Generic)
data/examples/declaration/data/record-multi-const-out.hsdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−-- | Something.
4−data Foo
5− = Foo
6− { -- | X
7− fooX :: Int,
8− -- | Y
9− fooY :: Int
10− }
11− | Bar
12− { -- | X
13− barX :: Int,
14− -- | Y
15− barY :: Int
16− }
17− deriving (Eq, Show)
data/examples/declaration/data/record-multi-const.hsdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−-- | Something.
4−
5−data Foo = Foo
6− { fooX :: Int -- ^ X
7− , fooY :: Int -- ^ Y
8− } |
9− Bar
10− { barX :: Int -- ^ X
11− , barY :: Int -- ^ Y
12− }
13− deriving (Eq, Show)
data/examples/declaration/data/record-out.hs+20−19
@@ -1,23 +1,24 @@
11module Main where
22
33-- | Something.
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− }
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+ }
2324 deriving (Eq, Show)
data/examples/declaration/data/simple-broken-out.hs+2−1
@@ -1,7 +1,8 @@
11module Main where
22
33-- | Here we go.
4−data Foo = Foo {unFoo :: Int}
4+data Foo
5+ = Foo {unFoo :: Int}
56 deriving (Eq)
67
78-- | And once again.
data/examples/declaration/data/unnamed-field-comment-0-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−data Foo
2− = -- | Bar
3− Bar
4− Field1
5− -- ^ Field 1
6− Field2
7− -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-0.hsdeleted−5
@@ -1,5 +0,0 @@
1−data Foo
2− = -- | Bar
3− Bar
4− Field1 -- ^ Field 1
5− Field2 -- ^ Field 2
data/examples/declaration/data/unnamed-field-comment-1-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−data X
2− = B
3− !Int
4− -- ^ y
5− C
data/examples/declaration/data/unnamed-field-comment-1.hsdeleted−4
@@ -1,4 +0,0 @@
1−data X
2− = B
3− !Int -- ^ y
4− C
data/examples/declaration/data/with-comment-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−data A
2− = B -- C
3− | -- D
4− E
data/examples/declaration/data/with-comment.hsdeleted−5
@@ -1,5 +0,0 @@
1−data A =
2− B -- C
3−
4− -- D
5− | E
data/examples/declaration/data/with-weird-haddock-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−data PlusLevel' t
2− = -- | @n + ℓ@.
3− Plus Integer (LevelAtom' t)
4− deriving (Show, Data)
data/examples/declaration/data/with-weird-haddock.hsdeleted−2
@@ -1,2 +0,0 @@
1−data PlusLevel' t = Plus Integer (LevelAtom' t) -- ^ @n + ℓ@.
2− deriving (Show, Data)
data/examples/declaration/instance/associated-data-out.hs+2
@@ -11,7 +11,9 @@ instance Foo Double where
1111 Double
1212
1313instance Foo [a] where
14+
1415 data Bar [a]
1516 = ListBar [Bar a]
17+
1618 data Baz [a]
1719 = ListBaz
data/examples/declaration/instance/associated-data.hs−1
@@ -13,7 +13,6 @@ instance Foo Double where
1313
1414instance Foo [a]
1515 where
16−
1716 data Bar [a] =
1817 ListBar [Bar a]
1918 data Baz [a] =
data/examples/declaration/instance/associated-types-out.hs+1
@@ -3,6 +3,7 @@
33instance Foo Int where type Bar Int = Double
44
55instance Foo Double where
6+
67 type
78 Bar
89 Double =
data/examples/declaration/instance/associated-types.hs−2
@@ -9,7 +9,5 @@ instance Foo Double
99 Double
1010 =
1111 [Double]
12−
13−
1412 type instance Baz Double
1513 = [Double]
data/examples/declaration/instance/data-family-instances-gadt-out.hs+2−4
@@ -3,11 +3,9 @@
33
44data instance Bar Int a where
55 SameBar ::
6− Bar
7− Int
6+ Bar Int
87 Int
98 CloseBar :: Bar Int Double
109 OtherBar ::
11− Bar
12− Int
10+ Bar Int
1311 a
data/examples/declaration/instance/data-family-instances-newtype-out.hs+4−3
@@ -1,6 +1,7 @@
11{-# LANGUAGE GADTSyntax #-}
22{-# LANGUAGE TypeFamilies #-}
33
4−newtype instance Foo [Double] = DoubleListFoo
5− { unDoubleListFoo :: Double
6− }
4+newtype instance Foo [Double]
5+ = DoubleListFoo
6+ { unDoubleListFoo :: Double
7+ }
data/examples/declaration/instance/instance-sigs-multiple-out.hs+2
@@ -1,10 +1,12 @@
11{-# LANGUAGE InstanceSigs #-}
22
33instance Applicative [] where
4+
45 pure ::
56 a ->
67 [a]
78 pure a = [a]
9+
810 (<*>) ::
911 [a] -> [a] -> [a]
1012 (<*>) _ _ = []
data/examples/declaration/instance/multi-parameter-out.hs+2
@@ -1,5 +1,7 @@
11instance MonadReader a ((->) a) where ask = id
22
33instance MonadState s (State s) where
4+
45 get = State.get
6+
57 put = State.put
data/examples/declaration/instance/newlines-after-where-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−instance Num X where
2− (+) = undefined
3−
4−instance Num Y where
5− (+) = undefined
data/examples/declaration/instance/newlines-after-where.hsdeleted−7
@@ -1,7 +0,0 @@
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.hsdeleted−18
@@ -1,18 +0,0 @@
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.hsdeleted−16
@@ -1,16 +0,0 @@
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,7 +1,9 @@
11instance Monoid Int where (<>) x y = x + y
22
33instance Enum Int where
4+
45 fromEnum x = x
6+
57 toEnum =
68 \x ->
79 x
data/examples/declaration/signature/minimal/minimal-out.hs+2
@@ -1,4 +1,5 @@
11class Foo a where
2+
23 {-# MINIMAL (==) | ((/=), foo) #-}
34
45 {-# MINIMAL
@@ -11,4 +12,5 @@ class Foo a where
1112 #-}
1213
1314 (==) :: a -> a -> Bool
15+
1416 (/=) :: a -> a -> Bool
data/examples/declaration/signature/specialize/specialize-instance-out.hs+4
@@ -3,12 +3,16 @@ data Foo a = Foo a
33data VT v m r = VT v m r
44
55instance (Eq a) => Eq (Foo a) where
6+
67 {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}
8+
79 (==) (Foo a) (Foo b) = (==) a b
810
911instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where
12+
1013 {-# SPECIALIZE instance
1114 ( Factored m Int => Num (VT U.Vector m Int)
1215 )
1316 #-}
17+
1418 VT x + VT y = VT $ V.zipWith (+) x y
data/examples/declaration/signature/standalone-kind-out.hsdeleted−13
@@ -1,13 +0,0 @@
1−{-# LANGUAGE StandaloneKindSignatures #-}
2−
3−type T ::
4− (k -> Type) ->
5− k ->
6− Type
7−data T m a = MkT (m a) (T Maybe (m a))
8−
9−type C1 :: Type -> Constraint
10−class C1 a
11−
12−type F :: Type -> Type
13−type family F
data/examples/declaration/signature/standalone-kind.hsdeleted−13
@@ -1,13 +0,0 @@
1−{-# LANGUAGE StandaloneKindSignatures #-}
2−
3−type T :: (k -> Type)
4− -> k
5− -> Type
6−
7−data T m a = MkT (m a) (T Maybe (m a))
8−
9−type C1 :: Type -> Constraint
10−class C1 a
11−
12−type F :: Type -> Type
13−type family F
data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs+1
@@ -1,2 +1,3 @@
11fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool)
2+
23fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)
data/examples/declaration/signature/type/multi-value-out.hs−5
@@ -2,11 +2,6 @@ foo, bar :: Int
22foo = 1
33bar = 2
44
5−a, b, c :: Int
6−a = 1
7−b = 2
8−c = 3
9−
105foo,
116 bar,
127 baz ::
data/examples/declaration/signature/type/multi-value.hs−5
@@ -2,11 +2,6 @@ foo, bar :: Int
22foo = 1
33bar = 2
44
5−a, b, c :: Int
6−a = 1
7−b = 2
8−c = 3
9−
105foo,
116 bar,
127 baz :: Int
data/examples/declaration/signature/type/unrelated-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−clientFunc1 :: SomeType1
2−clientFunc2 :: SomeType2
3−clientFunc3 :: SomeType3
4−clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz
data/examples/declaration/signature/type/unrelated.hsdeleted−4
@@ -1,4 +0,0 @@
1−clientFunc1 :: SomeType1
2−clientFunc2 :: SomeType2
3−clientFunc3 :: SomeType3
4−clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz
data/examples/declaration/splice/grouped-splices-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−$(deriveJSON fieldLabelMod ''A)
2−$(deriveJSON fieldLabelMod ''B)
3−$(deriveJSON fieldLabelMod ''C)
data/examples/declaration/splice/grouped-splices.hsdeleted−3
@@ -1,3 +0,0 @@
1−$(deriveJSON fieldLabelMod ''A)
2−$(deriveJSON fieldLabelMod ''B)
3−$(deriveJSON fieldLabelMod ''C)
data/examples/declaration/splice/splice-decl.hs+1
@@ -15,3 +15,4 @@ foo bar
1515-- TemplateHaskell allows Q () at the top level
1616do
1717 pure []
18+
data/examples/declaration/type-families/closed-type-family/multi-line-out.hs+5−6
@@ -1,7 +1,7 @@
11type family
22 Id a =
3− result | result -> a
4− where
3+ result
4+ | result -> a where
55 Id a =
66 a
77
@@ -10,15 +10,14 @@ type family
1010 (a :: k)
1111 b
1212 c =
13− foo | foo -> k b
14− where
13+ foo
14+ | foo -> k b where
1515 G a b c =
1616 (a, b)
1717
1818type family
1919 F a ::
20− * -> *
21− where
20+ * -> * where
2221 F Int = Double
2322 F Bool =
2423 Char
data/examples/declaration/type-synonyms/with-weird-haddock-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−type Elims =
2− -- | eliminations ordered left-to-right.
3− [Elim]
data/examples/declaration/type-synonyms/with-weird-haddock.hsdeleted−1
@@ -1 +0,0 @@
1−type Elims = [Elim] -- ^ eliminations ordered left-to-right.
data/examples/declaration/type/visible-forall-out.hsdeleted−2
@@ -1,2 +0,0 @@
1−-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
2−data T :: forall k -> k -> Type
data/examples/declaration/type/visible-forall.hsdeleted−2
@@ -1,2 +0,0 @@
1−-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst
2−data T :: forall k -> k -> Type
data/examples/declaration/value/function/application-1-out.hsdeleted−19
@@ -1,19 +0,0 @@
1−main =
2− do
3− x
4− y
5− z
6−
7−main =
8− case foo of
9− x -> a
10− foo
11− a
12− b
13−
14−main =
15− do
16− if x then y else z
17− foo
18− a
19− b
data/examples/declaration/value/function/application-1.hsdeleted−14
@@ -1,14 +0,0 @@
1−main =
2− do
3− x
4− y
5− z
6−
7−main =
8− case foo of
9− x -> a
10− foo a b
11−
12−main = do
13− if x then y else z
14− foo a b
data/examples/declaration/value/function/application-0-out.hs → data/examples/declaration/value/function/application-out.hsrenamed

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/arg-breakpoints-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo
2− bar =
3− body
data/examples/declaration/value/function/arg-breakpoints.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo
2− bar =
3− body
data/examples/declaration/value/function/arrow/expression-applications-out.hsnew file+9
@@ -0,0 +1,9 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo x y = x -< y
4+
5+bar f x =
6+ f x -< -- Hello
7+ x -- World
8+
9+baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-applications.hsnew file+9
@@ -0,0 +1,9 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo x y = x -< y
4+
5+bar f x
6+ = f x -- Hello
7+ -< x -- World
8+
9+baz x y = x -<< y
data/examples/declaration/value/function/arrow/expression-forms-out.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f g x y = (| test (f -< x) (g -< y) |)
4+
5+bar f g x y =
6+ (|
7+ test
8+ ( f -<
9+ x
10+ )
11+ ( g -<
12+ y
13+ )
14+ |)
data/examples/declaration/value/function/arrow/expression-forms.hsnew file+11
@@ -0,0 +1,11 @@
1+{-# LANGUAGE Arrows #-}
2+
3+foo f g x y = (| test (f -< x) (g -< y) |)
4+
5+bar f g x y = (|
6+ test
7+ (f
8+ -< x)
9+ (g
10+ -< y)
11+ |)
data/examples/declaration/value/function/arrow/multiline-case-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−f = proc x -> do
4− x <-
5− case x of X -> x
6− -<
7− y
8− a -< b
data/examples/declaration/value/function/arrow/multiline-case.hsdeleted−7
@@ -1,7 +0,0 @@
1−{-# LANGUAGE Arrows #-}
2−
3−f = proc x -> do
4− x
5− <- case x of X -> x
6− -< y
7− a -< b
data/examples/declaration/value/function/arrow/proc-applications-out.hs+5−6
@@ -9,11 +9,10 @@ bar f x =
99 w
1010 )
1111 ->
12− f -- The value
13− -<
14− ( x, -- Foo
15− w, -- Bar
16− z -- Baz
17− )
12+ f -< -- The value
13+ ( x, -- Foo
14+ w, -- Bar
15+ z -- Baz
16+ )
1817
1918baz x = proc a -> a -<< x
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+14−18
@@ -19,11 +19,10 @@ foo
1919 )
2020 ( b,
2121 d
22+ ) -<
23+ ( b + 1, -- Funnel into arrow
24+ d * b
2225 )
23− -<
24− ( b + 1, -- Funnel into arrow
25− d * b
26− )
2726 if x `mod` y == 0 -- Basic condition
2827 then case e of -- Only left case is relevant
2928 Left
@@ -33,20 +32,18 @@ foo
3332 let v =
3433 u -- Actually never used
3534 ^ 2
36− in ( returnA
37− -<
38− -- Just do the calculation
39− (x + y * z)
35+ in ( returnA -<
36+ -- Just do the calculation
37+ (x + y * z)
4038 )
4139 else do
4240 let u = x -- Let bindings bind expressions, not commands
43− -- Could pattern match directly on x
41+ -- Could pattern match directly on x
4442 i <- case u of
4543 0 -> (g . h -< u)
4644 n ->
47− ( ( h . g
48− -<
49− y -- First actual use of y
45+ ( ( h . g -<
46+ y -- First actual use of y
5047 )
5148 )
5249 returnA -< ()
@@ -54,9 +51,8 @@ foo
5451 if i > 0
5552 then ma -< ()
5653 else returnA -< ()
57− returnA
58− -<
59− ( i
60− + x
61− * y -- Just do the calculation
62− )
54+ returnA -<
55+ ( i
56+ + x
57+ * y -- Just do the calculation
58+ )
data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs+2−3
@@ -13,6 +13,5 @@ barbaz f g = proc (a, b) -> do
1313
1414bazbar f = proc a -> do
1515 a <-
16− f
17− -<
18− a
16+ f -<
17+ a
data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs+7−9
@@ -11,12 +11,10 @@ bazbaz f g h = proc (a, b, c) -> do
1111 z <-
1212 h
1313 x
14− y
15− -<
16− ( a,
17− b,
18− c
19− )
20− returnA
21− -<
22− (x, y, z)
14+ y -<
15+ ( a,
16+ b,
17+ c
18+ )
19+ returnA -<
20+ (x, y, z)
data/examples/declaration/value/function/arrow/proc-forms1-out.hs+6−8
@@ -7,15 +7,13 @@ foo1 f g h x =
77 (|
88 test
99 ( h f
10− . h g
11− -<
12− y x
13− . y z
10+ . h g -<
11+ y x
12+ . y z
1413 )
1514 ( h g
16− . h f
17− -<
18− y z
19− . y x
15+ . h f -<
16+ y z
17+ . y x
2018 )
2119 |)
data/examples/declaration/value/function/arrow/proc-forms2-out.hs+6−10
@@ -4,19 +4,15 @@ 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− -<
17− (y x) . y z
18− ) |||
19− ( (h g . h f)
20− -<
21− y z . (y x)
22− )
15+ (h f . h g) -<
16+ (y x) . y z
17+ ||| (h g . h f) -<
18+ y z . (y x)
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+4−6
@@ -6,10 +6,8 @@ bar f g = proc a ->
66 if f a
77 then
88 f
9− . g
10− -<
11− a
9+ . g -<
10+ a
1211 else
13− g
14− -<
15− b
12+ g -<
13+ b
data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+4−5
@@ -6,14 +6,13 @@ bar f g = proc a ->
66 ( ( (f)
77 ( g
88 )
9− )
10− -<
11− ( ( ( ( ( ( g
12− a
13− )
9+ ) -<
10+ ( ( ( ( ( ( g
11+ a
1412 )
1513 )
1614 )
1715 )
1816 )
17+ )
1918 )
data/examples/declaration/value/function/arrow/recursive-procs-out.hs+10−14
@@ -3,21 +3,17 @@
33foo f g = proc (x, y) -> do
44 rec a <- f y -< x
55 b <-
6− g x
7− -<
8− y
9− bar
10− -<
11− ( a,
12− b
13− )
6+ g x -<
7+ y
8+ bar -<
9+ ( a,
10+ b
11+ )
1412 rec p <-
1513 f
16− p
17− -<
18− a
14+ p -<
15+ a
1916 rec q <-
2017 g
21− q
22− -<
23− b
18+ q -<
19+ b
data/examples/declaration/value/function/awkward-comment-0-out.hsdeleted−6
@@ -1,6 +0,0 @@
1−mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2−mergeErrorReply err1 reply -- XXX where to put it?
3− =
4− case reply of
5− Ok x state err2 -> Ok x state (mergeError err1 err2)
6− Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-0.hsdeleted−5
@@ -1,5 +0,0 @@
1−mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
2−mergeErrorReply err1 reply -- XXX where to put it?
3− = case reply of
4− Ok x state err2 -> Ok x state (mergeError err1 err2)
5− Error err2 -> Error (mergeError err1 err2)
data/examples/declaration/value/function/awkward-comment-1-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2−doForeign x = x
3− where
4− splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits
5− =
6− do
7− let l' = toFDesc l
8− r' <- irTerm (sMN 0 "__foreignCall") vs env r
9− return (l', r')
data/examples/declaration/value/function/awkward-comment-1.hsdeleted−7
@@ -1,7 +0,0 @@
1−doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
2−doForeign x = x
3− where
4− splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
5− = do let l' = toFDesc l
6− r' <- irTerm (sMN 0 "__foreignCall") vs env r
7− return (l', r')
data/examples/declaration/value/function/blank-lines-let-out.hsdeleted−6
@@ -1,6 +0,0 @@
1−foo =
2− let x = 10
3−
4− y = 11
5− z = 12
6− in x + y + z
data/examples/declaration/value/function/blank-lines-let.hsdeleted−9
@@ -1,9 +0,0 @@
1−foo =
2− let
3−
4− x = 10
5−
6− y = 11
7− z = 12
8−
9− in x + y + z
data/examples/declaration/value/function/blank-lines-where-out.hsdeleted−6
@@ -1,6 +0,0 @@
1−foo = x + y + z
2− where
3− x = 10
4−
5− y = 11
6− z = 12
data/examples/declaration/value/function/blank-lines-where.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo = x + y + z
2− where
3−
4− x = 10
5−
6− y = 11
7− z = 12
data/examples/declaration/value/function/block-arguments-out.hs−5
@@ -27,8 +27,3 @@ f8 = foo \x ->
2727 y
2828
2929f9 = foo do { bar } baz
30−
31−f10 = foo
32− do a
33− do b
34− do c
data/examples/declaration/value/function/block-arguments.hs−5
@@ -23,8 +23,3 @@ f8 = foo \x ->
2323 y
2424
2525f9 = foo do { bar } baz
26−
27−f10 = foo
28− do { a }
29− do { b }
30− do c
data/examples/declaration/value/function/do/blocks-out.hs−1
@@ -15,5 +15,4 @@ readInClause = do
1515 <|> do
1616 optional g_Semi
1717 void allspacing
18−
1918 return things
data/examples/declaration/value/function/do/comment-alignment-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−main = do
2− case blah of
3− Nothing -> return ()
4− Just xs -> do
5− forM_ xs foo
6− bar
7− -- and here it goes
8− unless bobla $
9− quux
data/examples/declaration/value/function/do/comment-alignment.hsdeleted−9
@@ -1,9 +0,0 @@
1−main = do
2− case blah of
3− Nothing -> return ()
4− Just xs -> do
5− forM_ xs foo
6− bar
7− -- and here it goes
8− unless bobla $
9− quux
data/examples/declaration/value/function/do/comment-spacing-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo = do
2− bar
3− -- foo
4− baz
5−
6− -- foo
7− quux
data/examples/declaration/value/function/do/comment-spacing.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo = do
2− bar
3− -- foo
4− baz
5−
6− -- foo
7− quux
data/examples/declaration/value/function/do/recursive-do-rec-out.hs−5
@@ -2,18 +2,13 @@
22
33foo = do
44 rec a <- b + 5
5−
65 let d = c
7−
86 b <- a * 5
9−
107 something
11−
128 c <- a + b
139 print c
1410 rec something $ do
1511 x <- a
1612 print x
17−
1813 y <- c
1914 print y
data/examples/declaration/value/function/if-with-comment-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo =
2− if undefined
3− then -- then comment
4− undefined
5− else -- else comment
6−
7− do
8− undefined
data/examples/declaration/value/function/if-with-comment.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo =
2− if undefined
3− -- then comment
4− then undefined
5− -- else comment
6− else
7− do
8− undefined
data/examples/declaration/value/function/implicit-params-out.hs−1
@@ -1,7 +1,6 @@
11{-# LANGUAGE ImplicitParams #-}
22
33sortBy :: (a -> a -> Bool) -> [a] -> [a]
4−sortBy = undefined
54
65sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
76sort = sortBy ?cmp
data/examples/declaration/value/function/implicit-params.hs−2
@@ -1,8 +1,6 @@
11{-# LANGUAGE ImplicitParams #-}
22sortBy :: (a -> a -> Bool) -> [a] -> [a]
33
4−sortBy = undefined
5−
64sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]
75sort = sortBy ?cmp
86
data/examples/declaration/value/function/infix/dollar-chains-out.hs+3−7
@@ -13,10 +13,6 @@ foo =
1313 throwIO (OrmoluCppEnabled path)
1414
1515foo =
16− bar $
17− baz $
18− quux
19−
20−x =
21− case l of { A -> B } $
22− case q of r -> s
16+ bar
17+ $ baz
18+ $ quux
data/examples/declaration/value/function/infix/dollar-chains.hs−4
@@ -16,7 +16,3 @@ foo =
1616 bar
1717 $ baz
1818 $ quux
19−
20−x =
21− case l of { A -> B } $
22− case q of r -> s
data/examples/declaration/value/function/infix/hanging-out.hs+3−4
@@ -17,7 +17,6 @@ update =
1717 `catch` \case
1818 a -> a
1919
20−foo =
21− bar
22− ++ case foo of
23− a -> a
20+foo = bar
21+ ++ case foo of
22+ a -> a
data/examples/declaration/value/function/infix/lenses-out.hs+7−8
@@ -1,12 +1,11 @@
11lenses =
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− # []
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+ # []
109
1110foo =
1211 a
data/examples/declaration/value/function/let-single-line-out.hs+1
@@ -5,6 +5,7 @@ foo x = let x = z where { z = 2 }; a = 3 in x
55foo x = let g :: Int -> Int; g = id in ()
66
77let a = b; c = do { foo; bar }; d = baz in b
8+
89let a = case True of { True -> foo; False -> bar }; b = foo a in b
910
1011foo x = let ?g = id; ?f = g in x
data/examples/declaration/value/function/list-notation-0-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−foo =
2− testCase "Foo" testFoo :
3− testCase "Bar" testBar :
4− testCase "Baz" testBaz :
5− []
data/examples/declaration/value/function/list-notation-0.hsdeleted−5
@@ -1,5 +0,0 @@
1−foo =
2− testCase "Foo" testFoo :
3− testCase "Bar" testBar :
4− testCase "Baz" testBaz :
5− []
data/examples/declaration/value/function/list-notation-1-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−instance A.ToJSON UpdateTable where
2− toJSON a =
3− A.object $
4− "TableName" .= updateTableName a :
5− "ProvisionedThroughput" .= updateProvisionedThroughput a :
6− case updateGlobalSecondaryIndexUpdates a of
7− [] -> []
8− l -> ["GlobalSecondaryIndexUpdates" .= l]
data/examples/declaration/value/function/list-notation-1.hsdeleted−7
@@ -1,7 +0,0 @@
1−instance A.ToJSON UpdateTable where
2− toJSON a = A.object
3− $ "TableName" .= updateTableName a
4− : "ProvisionedThroughput" .= updateProvisionedThroughput a
5− : case updateGlobalSecondaryIndexUpdates a of
6− [] -> []
7− l -> [ "GlobalSecondaryIndexUpdates" .= l ]
data/examples/declaration/value/function/list-notation-2-out.hsdeleted−6
@@ -1,6 +0,0 @@
1−-- A list of the element and all its parents up to the root node.
2−getPath tree t =
3− t :
4− case Map.lookup (getId t) tree of
5− Nothing -> []
6− Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-2.hsdeleted−5
@@ -1,5 +0,0 @@
1−-- A list of the element and all its parents up to the root node.
2−getPath tree t = t :
3− case Map.lookup (getId t) tree of
4− Nothing -> []
5− Just parent -> getPath tree parent
data/examples/declaration/value/function/list-notation-3-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−foo =
2− reportSDoc "tc.cc" 30 $
3− sep $ do
4− (prettyTCM q <+> " before compilation") : do
5− map (prettyTCM . map unArg . clPats) cls
6−
7−foo =
8− reportSDoc "tc.cc" 30 $
9− sep $ do
10− (prettyTCM q <+> " before compilation") :
11− do
12− map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/list-notation-3.hsdeleted−10
@@ -1,10 +0,0 @@
1−foo =
2− reportSDoc "tc.cc" 30 $ sep $ do
3− (prettyTCM q <+> " before compilation") : do
4− map (prettyTCM . map unArg . clPats) cls
5−
6−foo =
7− reportSDoc "tc.cc" 30 $ sep $ do
8− (prettyTCM q <+> " before compilation") :
9− do
10− map (prettyTCM . map unArg . clPats) cls
data/examples/declaration/value/function/multi-way-if-out.hs+4−10
@@ -4,13 +4,7 @@ foo x = if | x == 5 -> 5
44
55bar x y =
66 if
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
7+ | x > y -> x
8+ | x < y ->
9+ y
10+ | otherwise -> x
data/examples/declaration/value/function/multi-way-if.hs−5
@@ -7,8 +7,3 @@ 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.hsdeleted−5
@@ -1,5 +0,0 @@
1−x =
2− y
3− ++ f g -- commentA
4− -- commentB
5− -- commentC
data/examples/declaration/value/function/operator-comments-2.hsdeleted−4
@@ -1,4 +0,0 @@
1−x =
2− y ++ -- commentA
3−-- commentB
4− f g -- commentC
data/examples/declaration/value/function/operators-0-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−a =
2− b & c .~ d
3− & e
4− %~ f
5− g
data/examples/declaration/value/function/operators-0.hsdeleted−4
@@ -1,4 +0,0 @@
1−a =
2− b & c .~ d
3− & e %~ f
4− g
data/examples/declaration/value/function/operators-1-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−foo =
2− f
3− . g
4− =<< h . i
data/examples/declaration/value/function/operators-1.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo = f
2− . g
3− =<< h . i
data/examples/declaration/value/function/operators-2-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−foo n
2− | x || y && z || n ** x
3− || x && n =
4− 42
data/examples/declaration/value/function/operators-2.hsdeleted−4
@@ -1,4 +0,0 @@
1−foo n
2− | x || y && z || n ** x
3− || x && n =
4− 42
data/examples/declaration/value/function/operators-3-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo =
2− op <> n <+> colon <+> prettySe <+> text "="
3− <+> prettySe <> text sc
data/examples/declaration/value/function/operators-3.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo =
2− op <> n <+> colon <+> prettySe <+> text "=" <+>
3− prettySe <> text sc
data/examples/declaration/value/function/operators-4-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo =
2− line <> bindingOf <+> text "=" <+> tPretty <+> colon
3− <+> align <> prettyPs
data/examples/declaration/value/function/operators-4.hsdeleted−3
@@ -1,3 +0,0 @@
1−foo =
2− line <> bindingOf <+> text "=" <+> tPretty <+> colon <+>
3− align <> prettyPs
data/examples/declaration/value/function/operators-5-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−foo =
2− map bar $
3− [ baz
4− ]
5− ++ quux
data/examples/declaration/value/function/operators-5.hsdeleted−4
@@ -1,4 +0,0 @@
1−foo =
2− map bar $
3− [ baz
4− ] ++ quux
data/examples/declaration/value/function/operators-6-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−type PermuteRef =
2− "a"
3− :> ( "b" :> "c" :> End
4− :<|> "c" :> "b" :> End
5− )
6− :<|> "b"
7− :> ( "a" :> "c" :> End
8− :<|> "c" :> "a" :> End
9− )
data/examples/declaration/value/function/operators-6.hsdeleted−7
@@ -1,7 +0,0 @@
1−type PermuteRef =
2− "a" :> ( "b" :> "c" :> End
3− :<|> "c" :> "b" :> End
4− )
5− :<|> "b" :> ( "a" :> "c" :> End
6− :<|> "c" :> "a" :> End
7− )
data/examples/declaration/value/function/overindentation-out.hs+9−11
@@ -1,11 +1,9 @@
1−reallyincrediblyLongName =
2− f
3− a
4− A
5− { reallyincrediblyLongName =
6− f
7− a
8− A
9− { reallyincrediblyLongName
10− }
11− }
1+reallyincrediblyLongName = f
2+ a
3+ A
4+ { reallyincrediblyLongName = f
5+ a
6+ A
7+ { reallyincrediblyLongName
8+ }
9+ }
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,3 +13,6 @@ 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,3 +10,6 @@ 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.hsnew file+27
@@ -0,0 +1,27 @@
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.hs → data/examples/declaration/value/function/record-constructors.hsrenamed

The content is the same.

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

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/record/wildcards-out.hs → data/examples/declaration/value/function/record-wildcards-out.hsrenamed+6−7
@@ -3,12 +3,11 @@
33
44foo x y = Foo {x, y}
55
6−bar x y z =
7− Bar
8− { x,
9− y,
10− z,
11− ..
12− }
6+bar x y z = Bar
7+ { x,
8+ y,
9+ z,
10+ ..
11+ }
1312
1413baz = 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/record/constructors-out.hsdeleted−31
@@ -1,31 +0,0 @@
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/dot-out.hsdeleted−15
@@ -1,15 +0,0 @@
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.hsdeleted−14
@@ -1,14 +0,0 @@
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.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo =
2− Foo
3− { foo =
4− -- Blah blah
5− case x of
6− Blah -> 1
7− Blim -> 2
8− }
data/examples/declaration/value/function/record/hanging-after-equal-con.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo = Foo
2− { foo =
3− -- Blah blah
4− case x of
5− Blah -> 1
6− Blim -> 2
7− }
data/examples/declaration/value/function/record/hanging-after-equal-update-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo =
2− foo
3− { foo =
4− -- Blah blah
5− case x of
6− Blah -> 1
7− Blim -> 2
8− }
data/examples/declaration/value/function/record/hanging-after-equal-update.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo = foo
2− { foo =
3− -- Blah blah
4− case x of
5− Blah -> 1
6− Blim -> 2
7− }
data/examples/declaration/value/function/record/inter-comments-out.hsdeleted−13
@@ -1,13 +0,0 @@
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.hsdeleted−11
@@ -1,11 +0,0 @@
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/type-applications-and-splice-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE TypeApplications #-}
3−
4−staticKey name = [|sing @ $(symFQN name)|]
data/examples/declaration/value/function/type-applications-and-splice.hsdeleted−4
@@ -1,4 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE TypeApplications #-}
3−
4−staticKey name = [| sing @ $(symFQN name) |]
data/examples/declaration/value/function/type-applications-out.hs−6
@@ -8,9 +8,3 @@ 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,8 +6,3 @@ 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.hsdeleted−6
@@ -1,6 +0,0 @@
1−import Foo1 (Bar1 (..), Baz1)
2−import Foo2 (Bar2 (..), Baz2)
3−import Foo3 (Bar3 (x1, x2, x3))
4−import Foo4 (Bar4 (x1, x2))
5−import Foo5 (Bar5 (x1))
6−import Foo6 (Bar6 (..))
data/examples/import/deduplication-bug.hsdeleted−6
@@ -1,6 +0,0 @@
1−import Foo1 (Bar1, Baz1, Bar1(..))
2−import Foo2 (Bar2(..), Baz2, Bar2)
3−import Foo3 (Bar3(x1,x3), Bar3(x1, x2))
4−import Foo4 (Bar4(x1), Bar4(x2))
5−import Foo5 (Bar5, Bar5(x1))
6−import Foo6 (Bar6(x1), Bar6(..))
data/examples/import/explicit-imports-out.hs+4−4
@@ -1,12 +1,12 @@
11import qualified MegaModule as M
2− ( Either,
2+ ( (<<<),
3+ (>>>),
4+ Either,
35 Maybe (Just, Nothing),
46 MaybeT (..),
5− Monad (return, (>>), (>>=)),
7+ Monad ((>>), (>>=), return),
68 MonadBaseControl,
79 join,
810 liftIO,
911 void,
10− (<<<),
11− (>>>),
1212 )
data/examples/import/explicit-imports-with-comments-out.hs+2−3
@@ -1,7 +1,6 @@
11import qualified MegaModule as M
22 ( -- (1)
3− -- (2)
4− Either, -- (3)
5− (<<<),
3+ (<<<), -- (2)
64 (>>>),
5+ Either, -- (3)
76 )
data/examples/import/merging-0-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−import Foo
2−import Foo (bar, foo)
3−import Foo as F
data/examples/import/merging-0.hsdeleted−4
@@ -1,4 +0,0 @@
1−import Foo
2−import Foo (foo)
3−import Foo (bar)
4−import Foo as F
data/examples/import/merging-1-out.hsdeleted−2
@@ -1,2 +0,0 @@
1−import "bar" Foo (bar)
2−import "foo" Foo (baz, foo)
data/examples/import/merging-1.hsdeleted−3
@@ -1,3 +0,0 @@
1−import "foo" Foo (foo)
2−import "bar" Foo (bar)
3−import "foo" Foo (baz)
data/examples/import/merging-2-out.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Foo hiding (bar4, foo2)
2−import qualified Foo (bar3, foo1)
data/examples/import/merging-2.hsdeleted−4
@@ -1,4 +0,0 @@
1−import qualified Foo (foo1)
2−import Foo hiding (foo2)
3−import qualified Foo (bar3)
4−import Foo hiding (bar4)
data/examples/import/misc-out.hs+6
@@ -1,5 +1,11 @@
11import A hiding
22 ( foobarbazqux,
3+ foobarbazqux,
4+ foobarbazqux,
5+ foobarbazqux,
6+ foobarbazqux,
7+ foobarbazqux,
8+ foobarbazqux,
39 )
410import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)
511import Name hiding ()
data/examples/import/nested-explicit-imports-out.hs+6−6
@@ -1,10 +1,10 @@
11import qualified MegaModule as M
2− ( Either,
2+ ( (<<<),
3+ (>>>),
4+ Either,
35 Monad
4− ( return,
5− (>>),
6− (>>=)
6+ ( (>>),
7+ (>>=),
8+ return
79 ),
8− (<<<),
9− (>>>),
1010 )
data/examples/import/qualified-post-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−{-# LANGUAGE ImportQualifiedPost #-}
2−
3−import Data.Text qualified (a, b, c)
4−import Data.Text qualified hiding (a, b, c)
5−import Data.Text qualified as T
data/examples/import/qualified-post.hsdeleted−5
@@ -1,5 +0,0 @@
1−{-# LANGUAGE ImportQualifiedPost #-}
2−
3−import qualified Data.Text as T
4−import qualified Data.Text (a, c, b)
5−import Data.Text qualified hiding (c, b, a)
data/examples/import/qualified-prelude-out.hs+1−1
@@ -1,4 +1,4 @@
11module P where
22
3−import Prelude hiding (id, (.))
3+import Prelude hiding ((.), id)
44import qualified Prelude
data/examples/import/simple-out.hs+3−2
@@ -1,5 +1,6 @@
11import Data.Text
2+import Data.Text
3+import qualified Data.Text as T
4+import qualified Data.Text (a, b, c)
25import Data.Text (a, b, c)
36import Data.Text hiding (a, b, c)
4−import qualified Data.Text (a, b, c)
5−import qualified Data.Text as T
data/examples/import/simple.hs−2
@@ -4,5 +4,3 @@ import qualified Data.Text as T
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.hsdeleted−1
@@ -1 +0,0 @@
1−import Linear.Vector (Additive (..), (*^), (^*))
data/examples/import/sorted-export-list.hsdeleted−1
@@ -1 +0,0 @@
1−import Linear.Vector (Additive (..), (*^), (^*))
data/examples/module-header/double-dot-with-names-out.hs+6−1
@@ -1,6 +1,11 @@
11{-# LANGUAGE PatternSynonyms #-}
22
3−module ExportSyntax (A (.., NoA), Q (F, ..), G (T, .., U)) where
3+module ExportSyntax
4+ ( A (.., NoA),
5+ Q (F, ..),
6+ G (T, .., U),
7+ )
8+where
49
510data A = A | B
611
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+4−1
@@ -3,6 +3,9 @@
33-}
44
55-- | This is the module's Haddock.
6−module Main (main) where
6+module Main
7+ ( main,
8+ )
9+where
710
811main = return ()
data/examples/module-header/shebang-out.hs−1
@@ -1,5 +1,4 @@
11#! /usr/bin/env runhaskell
2−
32import Prelude
43
54main :: IO ()
data/examples/module-header/shebang-with-pragmas-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−#!/usr/bin/env stack
2−
3−{-# LANGUAGE OverloadedStrings #-}
4−
5−main = pure ()
data/examples/module-header/shebang-with-pragmas.hsdeleted−5
@@ -1,5 +0,0 @@
1−#!/usr/bin/env stack
2−
3−{-# LANGUAGE OverloadedStrings #-}
4−
5−main = pure ()
data/examples/module-header/shebang.hs−1
@@ -1,5 +1,4 @@
11#! /usr/bin/env runhaskell
2−
32import Prelude
43
54main :: IO ()
data/examples/module-header/singleline-empty-out.hs+4−1
@@ -1,2 +1,5 @@
11-- | This demonstrates a BUG.
2−module Foo () where
2+module Foo
3+ (
4+ )
5+where
data/examples/module-header/stack-header-0-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−-- stack runhaskell
2−
3−{-# LANGUAGE OverloadedStrings #-}
4−
5−main = return ()
6−
7−-- stack runhaskell
data/examples/module-header/stack-header-0.hsdeleted−4
@@ -1,4 +0,0 @@
1−-- stack runhaskell
2−{-# LANGUAGE OverloadedStrings #-}
3−main = return ()
4−-- stack runhaskell
data/examples/module-header/stack-header-1-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−#!/usr/bin/env stack
2−-- stack runhaskell
3−
4−{-# LANGUAGE OverloadedStrings #-}
5−
6−main = return ()
7−
8−-- stack runhaskell
data/examples/module-header/stack-header-1.hsdeleted−5
@@ -1,5 +0,0 @@
1−#!/usr/bin/env stack
2−-- stack runhaskell
3−{-# LANGUAGE OverloadedStrings #-}
4−main = return ()
5−-- stack runhaskell
data/examples/module-header/stack-header-2-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−#!/usr/bin/env stack
2−{- stack
3− script
4− --resolver lts-6.25
5− --package turtle
6− --package "stm async"
7− --package http-client,http-conduit
8−-}
9−
10−{-# LANGUAGE OverloadedStrings #-}
11−
12−main = return ()
data/examples/module-header/stack-header-2.hsdeleted−12
@@ -1,12 +0,0 @@
1−#!/usr/bin/env stack
2−{- stack
3− script
4− --resolver lts-6.25
5− --package turtle
6− --package "stm async"
7− --package http-client,http-conduit
8−-}
9−
10−{-# LANGUAGE OverloadedStrings #-}
11−
12−main = return ()
data/examples/module-header/warning-pragma-multiline-out.hs+4−1
@@ -1,6 +1,9 @@
11module Test
22 {-# DEPRECATED "This module is unstable" #-}
3− (foo, bar, baz)
3+ ( foo,
4+ bar,
5+ baz,
6+ )
47where
58
69import Blah
data/examples/module-header/warning-pragma-out.hs+1−3
@@ -1,5 +1,3 @@
11module Test
2− {-# WARNING
3− "This module is very internal"
4− #-}
2+ {-# WARNING "This module is very internal" #-}
53where
data/examples/other/argument-comment-out.hs+1
@@ -9,6 +9,7 @@ foo ::
99 -- | Foo
1010 Int ->
1111 Int
12+
1213foo ::
1314 Foo a =>
1415 -- | Foo
data/examples/other/comment-after-preceding-haddock-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−-- | A
4−
5−-- B
6−
7−type D = E
8−
9−-- | This is 'f'
10−
11−-- * Comment
12−f :: a -> b
data/examples/other/comment-after-preceding-haddock.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−-- | A
4−
5−-- B
6−
7−type D = E
8−
9−-- | This is 'f'
10−
11−-- * Comment
12−f :: a -> b
data/examples/other/comment-alignment-out.hs+1
@@ -1,4 +1,5 @@
11class Foo a where
2+
23 -- | Foo.
34 foo ::
45 Int ->
data/examples/other/comment-before-hanging-out.hsdeleted−5
@@ -1,5 +0,0 @@
1−x = Just
2− -- comment
3− do
4− foo
5− bar
data/examples/other/comment-before-hanging.hsdeleted−5
@@ -1,5 +0,0 @@
1−x = Just
2− -- comment
3− do
4− foo
5− bar
data/examples/other/comment-glued-together-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Main (main) where
2−
3−-- | Foo.
4−
5−-- Bar
6−main :: IO ()
7−main = return ()
data/examples/other/comment-glued-together.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−{- | Foo. -}
4−-- Bar
5−main :: IO ()
6−main = return ()
data/examples/other/comment-trailing-space-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−data T
2− = {-
3−
4− some multi-line comment
5−
6− with empty lines
7−
8− -}
9− A
data/examples/other/comment-trailing-space.hsdeleted−9
@@ -1,9 +0,0 @@
1−data T
2− = {-
3−
4− some multi-line comment
5−
6− with empty lines
7−
8− -}
9− A
data/examples/other/comment-two-blocks-out.hs+2−2
@@ -2,7 +2,7 @@ newNames :: [(String, String)]
22newNames =
33 let (*) = flip (,)
44 in [ "Control" * "Monad"
5− -- Foo
5+ -- Foo
66
7− -- Bar
7+ -- Bar
88 ]
data/examples/other/cpp/continuation-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo :: Int
2−foo = 5
3−
4−#define message_for(a, b) \
5− printf(#a " and " #b ": We love you!\n")
6−
7−bar :: Int
8−bar = 6
data/examples/other/cpp/continuation.hsdeleted−8
@@ -1,8 +0,0 @@
1−foo :: Int
2−foo = 5
3−
4−#define message_for(a, b) \
5− printf(#a " and " #b ": We love you!\n")
6−
7−bar :: Int
8−bar = 6
data/examples/other/cpp/lonely-hash-out.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Main (main) where
2−
3−import Data.Void
4−import Test.Hspec
5−import Test.Hspec.Megaparsec
6−import Text.Megaparsec
7−import Text.Megaparsec.Char
8−
9−# if !MIN_VERSION_base(4,13,0)
10−import Data.Semigroup ((<>))
11−# endif
12−
13−main :: IO ()
14−main = return ()
data/examples/other/cpp/lonely-hash.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Main (main) where
2−
3−import Data.Void
4−import Test.Hspec
5−import Test.Hspec.Megaparsec
6−import Text.Megaparsec
7−import Text.Megaparsec.Char
8−
9−# if !MIN_VERSION_base(4,13,0)
10−import Data.Semigroup ((<>))
11−# endif
12−
13−main :: IO ()
14−main = return ()
data/examples/other/cpp/separation-0a-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−instance Stream s => Monad (ParsecT e s m) where
2− return = pure
3− (>>=) = pBind
4−
5−#if !(MIN_VERSION_base(4,13,0))
6− fail = Fail.fail
7−#endif
data/examples/other/cpp/separation-0a.hsdeleted−6
@@ -1,6 +0,0 @@
1−instance Stream s => Monad (ParsecT e s m) where
2− return = pure
3− (>>=) = pBind
4−#if !(MIN_VERSION_base(4,13,0))
5− fail = Fail.fail
6−#endif
data/examples/other/cpp/separation-0b-out.hsdeleted−10
@@ -1,10 +0,0 @@
1−instance Stream s => Monad (ParsecT e s m) where
2− return = pure
3− (>>=) = pBind
4−
5−#if !(MIN_VERSION_base(4,13,0))
6− fail = Fail.fail
7−#endif
8−
9−foo :: Int
10−foo = undefined
data/examples/other/cpp/separation-0b.hsdeleted−9
@@ -1,9 +0,0 @@
1−instance Stream s => Monad (ParsecT e s m) where
2− return = pure
3− (>>=) = pBind
4−#if !(MIN_VERSION_base(4,13,0))
5− fail = Fail.fail
6−#endif
7−
8−foo :: Int
9−foo = undefined
data/examples/other/cpp/separation-1a-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−decompressingPipe ::
2− (PrimMonad m, MonadThrow m, MonadResource m) =>
3− CompressionMethod ->
4− ConduitT ByteString ByteString m ()
5−decompressingPipe Store = C.awaitForever C.yield
6−decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7−
8−#ifdef ENABLE_BZIP2
9−decompressingPipe BZip2 = BZ.bunzip2
10−#else
11−decompressingPipe BZip2 = throwM BZip2Unsupported
12−#endif
data/examples/other/cpp/separation-1a.hsdeleted−11
@@ -1,11 +0,0 @@
1−decompressingPipe
2− :: (PrimMonad m, MonadThrow m, MonadResource m)
3− => CompressionMethod
4− -> ConduitT ByteString ByteString m ()
5−decompressingPipe Store = C.awaitForever C.yield
6−decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7−#ifdef ENABLE_BZIP2
8−decompressingPipe BZip2 = BZ.bunzip2
9−#else
10−decompressingPipe BZip2 = throwM BZip2Unsupported
11−#endif
data/examples/other/cpp/separation-1b-out.hsdeleted−15
@@ -1,15 +0,0 @@
1−decompressingPipe ::
2− (PrimMonad m, MonadThrow m, MonadResource m) =>
3− CompressionMethod ->
4− ConduitT ByteString ByteString m ()
5−decompressingPipe Store = C.awaitForever C.yield
6−decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7−
8−#ifdef ENABLE_BZIP2
9−decompressingPipe BZip2 = BZ.bunzip2
10−#else
11−decompressingPipe BZip2 = throwM BZip2Unsupported
12−#endif
13−
14−foo :: Int
15−foo = undefined
data/examples/other/cpp/separation-1b.hsdeleted−14
@@ -1,14 +0,0 @@
1−decompressingPipe
2− :: (PrimMonad m, MonadThrow m, MonadResource m)
3− => CompressionMethod
4− -> ConduitT ByteString ByteString m ()
5−decompressingPipe Store = C.awaitForever C.yield
6−decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
7−#ifdef ENABLE_BZIP2
8−decompressingPipe BZip2 = BZ.bunzip2
9−#else
10−decompressingPipe BZip2 = throwM BZip2Unsupported
11−#endif
12−
13−foo :: Int
14−foo = undefined
data/examples/other/cpp/separation-2a-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−ffff, ffffffff :: Natural
2−
3−#ifdef HASKELL_ZIP_DEV_MODE
4−ffff = 200
5−ffffffff = 5000
6−#else
7−ffff = 0xffff
8−ffffffff = 0xffffffff
9−#endif
data/examples/other/cpp/separation-2a.hsdeleted−8
@@ -1,8 +0,0 @@
1−ffff, ffffffff :: Natural
2−#ifdef HASKELL_ZIP_DEV_MODE
3−ffff = 200
4−ffffffff = 5000
5−#else
6−ffff = 0xffff
7−ffffffff = 0xffffffff
8−#endif
data/examples/other/cpp/separation-2b-out.hsdeleted−11
@@ -1,11 +0,0 @@
1−ffff, ffffffff :: Natural
2−#ifdef HASKELL_ZIP_DEV_MODE
3−ffff = 200
4−ffffffff = 5000
5−#else
6−ffff = 0xffff
7−ffffffff = 0xffffffff
8−#endif
9−
10−foo :: Int
11−foo = undefined
data/examples/other/cpp/separation-2b.hsdeleted−11
@@ -1,11 +0,0 @@
1−ffff, ffffffff :: Natural
2−#ifdef HASKELL_ZIP_DEV_MODE
3−ffff = 200
4−ffffffff = 5000
5−#else
6−ffff = 0xffff
7−ffffffff = 0xffffffff
8−#endif
9−
10−foo :: Int
11−foo = undefined
data/examples/other/cpp/shifted-out.hsdeleted−21
@@ -1,21 +0,0 @@
1−sinkData h compression = do
2− (uncompressedSize, crc32, compressedSize) <-
3− case compression of
4− Store ->
5− withCompression
6− dataSink
7− Deflate ->
8− withCompression $
9− Z.compress 9 (Z.WindowBits (-15)) .| dataSink
10−#ifdef ENABLE_BZIP2
11− BZip2 -> withCompression $
12− BZ.bzip2 .| dataSink
13−#else
14− BZip2 -> throwM BZip2Unsupported
15−#endif
16− return
17− DataDescriptor
18− { ddCRC32 = fromIntegral crc32,
19− ddCompressedSize = compressedSize,
20− ddUncompressedSize = uncompressedSize
21− }
data/examples/other/cpp/shifted.hsdeleted−17
@@ -1,17 +0,0 @@
1−sinkData h compression = do
2− (uncompressedSize, crc32, compressedSize) <-
3− case compression of
4− Store -> withCompression
5− dataSink
6− Deflate -> withCompression $
7− Z.compress 9 (Z.WindowBits (-15)) .| dataSink
8−#ifdef ENABLE_BZIP2
9− BZip2 -> withCompression $
10− BZ.bzip2 .| dataSink
11−#else
12− BZip2 -> throwM BZip2Unsupported
13−#endif
14− return DataDescriptor
15− { ddCRC32 = fromIntegral crc32
16− , ddCompressedSize = compressedSize
17− , ddUncompressedSize = uncompressedSize }
data/examples/other/cpp/simple-import-out.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Main (main) where
2−
3−import Data.Void
4−import Test.Hspec
5−import Test.Hspec.Megaparsec
6−import Text.Megaparsec
7−import Text.Megaparsec.Char
8−
9−#if !MIN_VERSION_base(4,13,0)
10−import Data.Semigroup ((<>))
11−#endif
12−
13−main :: IO ()
14−main = return ()
data/examples/other/cpp/simple-import.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Main (main) where
2−
3−import Data.Void
4−import Test.Hspec
5−import Test.Hspec.Megaparsec
6−import Text.Megaparsec
7−import Text.Megaparsec.Char
8−
9−#if !MIN_VERSION_base(4,13,0)
10−import Data.Semigroup ((<>))
11−#endif
12−
13−main :: IO ()
14−main = return ()
data/examples/other/disabling/indented-fragment-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo =
2− {- ORMOLU_DISABLE -}
3− testCase "Foo" testFoo :
4− testCase "Bar" testBar :
5− testCase "Baz" testBaz :
6− {- ORMOLU_ENABLE -}
7− []
data/examples/other/disabling/indented-fragment.hsdeleted−7
@@ -1,7 +0,0 @@
1−foo =
2− {- ORMOLU_DISABLE -}
3− testCase "Foo" testFoo :
4− testCase "Bar" testBar :
5− testCase "Baz" testBaz :
6− {- ORMOLU_ENABLE -}
7− []
data/examples/other/disabling/single-definition-out.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Foo (foo, bar) where
2−
3−{- ORMOLU_DISABLE -}
4−foo :: Int -> Int
5−foo = (+5)
6−{- ORMOLU_ENABLE -}
7−
8−bar :: Bool -> Bool
9−bar True = True
10−bar False = True
data/examples/other/disabling/single-definition.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Foo (foo,bar) where
2−
3−{- ORMOLU_DISABLE -}
4−foo :: Int -> Int
5−foo = (+5)
6−{- ORMOLU_ENABLE -}
7−
8−bar :: Bool -> Bool
9−bar True = True
10−bar False = True
data/examples/other/disabling/whole-file-out.hsdeleted−10
@@ -1,10 +0,0 @@
1−{- ORMOLU_DISABLE -}
2−
3−module Foo (foo,bar) where
4−
5−foo :: Int -> Int
6−foo = (+5)
7−
8−bar :: Bool -> Bool
9−bar True = True
10−bar False = True
data/examples/other/disabling/whole-file.hsdeleted−10
@@ -1,10 +0,0 @@
1−{- ORMOLU_DISABLE -}
2−
3−module Foo (foo,bar) where
4−
5−foo :: Int -> Int
6−foo = (+5)
7−
8−bar :: Bool -> Bool
9−bar True = True
10−bar False = True
data/examples/other/empty-forall-out.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- Empty foralls are handled correctly in different situations.
2−
3−data D = forall. D Int
4−
5−data G where
6− G :: forall. Int -> G
7−
8−f :: forall. a -> a
9−f x = x
10−
11−type family T x where
12− forall. T x = x
13−
14−{-# RULES
15−"r"
16− r a =
17− ()
18− #-}
data/examples/other/empty-forall.hsdeleted−17
@@ -1,17 +0,0 @@
1−-- Empty foralls are handled correctly in different situations.
2−
3−data D = forall. D Int
4−
5−data G where
6− G :: forall. Int -> G
7−
8−f :: forall. a -> a
9−f x = x
10−
11−type family T x where
12− forall. T x = x
13−
14−{-# RULES
15− "r"
16− forall. r a = ()
17−#-}
data/examples/other/inline-comment-0-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−x = ({-a-} b, c)
2−
3−y = ({-a-} b)
data/examples/other/inline-comment-0.hsdeleted−3
@@ -1,3 +0,0 @@
1−x = ({-a-}b, c)
2−
3−y = ({-a-}b)
data/examples/other/inline-comment-1-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−showPs env ((n, _, Let _ t v) : bs) =
2− " " ++ show n ++ " : "
3− ++ showEnv env ({- normalise ctxt env -} t)
4− ++ " = "
5− ++ showEnv env ({- normalise ctxt env -} v)
6− ++ "\n"
7− ++ showPs env bs
8−showPs env ((n, _, b) : bs) =
9− " " ++ show n ++ " : "
10− ++ showEnv env ({- normalise ctxt env -} (binderTy b))
11− ++ "\n"
12− ++ showPs env bs
data/examples/other/inline-comment-1.hsdeleted−9
@@ -1,9 +0,0 @@
1−showPs env ((n, _, Let _ t v):bs)
2− = " " ++ show n ++ " : " ++
3− showEnv env ({- normalise ctxt env -} t) ++ " = " ++
4− showEnv env ({- normalise ctxt env -} v) ++
5− "\n" ++ showPs env bs
6−showPs env ((n, _, b):bs)
7− = " " ++ show n ++ " : " ++
8− showEnv env ({- normalise ctxt env -} (binderTy b)) ++
9− "\n" ++ showPs env bs
data/examples/other/multiline-forall-out.hs+2−1
@@ -12,7 +12,8 @@ data D
1212 )
1313 (x :: *)
1414 (y :: *).
15− D (f x y)
15+ D
16+ (f x y)
1617
1718data G where
1819 G ::
data/examples/other/multiple-blank-line-comment-out.hsdeleted−9
@@ -1,9 +0,0 @@
1−module A where
2−
3−a =
4− b
5− [ f
6− {-,
7−
8− -}
9− ]
data/examples/other/multiple-blank-line-comment.hsdeleted−10
@@ -1,10 +0,0 @@
1−module A where
2−
3−a =
4− b
5− [ f
6− {-,
7−
8−
9− -}
10− ]
data/examples/other/pragma-comments-after-out.hsdeleted−4
@@ -1,4 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−-- TODO: Fix and delete this pragma
4−{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
data/examples/other/pragma-comments-after.hsdeleted−3
@@ -1,3 +0,0 @@
1−{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- TODO: Fix and delete this pragma
2−{-# LANGUAGE AllowAmbiguousTypes #-}
3−{-# LANGUAGE ConstraintKinds #-}
data/examples/other/pragma-comments-out.hsdeleted−8
@@ -1,8 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−-- TODO This extension is probably too dangerous, remove it.
3−{-# LANGUAGE RecordWildCards #-}
4−-- Avoid warning produced by TH.
5−{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
6−
7−-- | Header comment.
8−module Foo () where
data/examples/other/pragma-comments.hsdeleted−11
@@ -1,11 +0,0 @@
1−-- | Header comment.
2−
3−{-# LANGUAGE OverloadedStrings #-}
4−
5−-- Avoid warning produced by TH.
6−{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
7−
8−-- TODO This extension is probably too dangerous, remove it.
9−{-# LANGUAGE RecordWildCards #-}
10−
11−module Foo () where
data/examples/other/pragma-out.hs+4−1
@@ -9,4 +9,7 @@
99{-# OPTIONS_HADDOCK prune, show-extensions #-}
1010
1111-- | Header comment.
12−module Foo () where
12+module Foo
13+ (
14+ )
15+where
data/examples/other/pragma-sorting-out.hsdeleted−11
@@ -1,11 +0,0 @@
1−{-# LANGUAGE NondecreasingIndentation #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- This gap is necessary for stylish Haskell not to re-arrange
5−-- NoMonoLocalBinds before TypeFamilies
6−{-# LANGUAGE NoMonoLocalBinds #-}
7−
8−module Foo
9− ( bar,
10− )
11−where
data/examples/other/pragma-sorting.hsdeleted−10
@@ -1,10 +0,0 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE NondecreasingIndentation #-}
4−-- This gap is necessary for stylish Haskell not to re-arrange
5−-- NoMonoLocalBinds before TypeFamilies
6−{-# LANGUAGE NoMonoLocalBinds #-}
7−
8−module Foo (
9− bar
10− ) where
default.nix+50−108
@@ -1,9 +1,7 @@
1−{ pkgs ? (import ./nix/nixpkgs { inherit system; })
2−, system ? builtins.currentSystem
3−, ormoluCompiler ? "ghc884" # the shell doesn't work with ghc8101 yet
4−}:
1+{ pkgs ? (import ./nix/nixpkgs) }:
52
63let
4+ ormoluCompiler = "ghc865";
75 source = pkgs.lib.sourceByRegex ./. [
86 "^.*\.md$"
97 "^app.*$"
@@ -16,71 +14,56 @@ let
1614 overrides = ormoluOverlay;
1715 };
1816 ormoluOverlay = self: super: {
19− "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };
17+ "ormolu" = super.callCabal2nix "ormolu" source { };
18+ # Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want
19+ # ghc-lib-parser-8.8.1. We disable Haddock generation because it's way
20+ # too slow.
21+ "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock
22+ (super.callHackage "ghc-lib-parser" "8.8.1" { });
2023 };
2124 ormolize = import ./nix/ormolize {
2225 inherit pkgs;
2326 inherit haskellPackages;
2427 };
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"]);
28+ # NOTE We have to exclude some directories for some packages because
29+ # Ormolu needs files to be parsable by Haddock which is not always the
30+ # case. For example some tests and examples do not parse.
31+ excludedHackageDirs = {
32+ "aws" = ["Examples"];
33+ "distributed-process" = ["benchmarks"];
34+ "esqueleto" = ["test"];
35+ "fay" = ["examples"];
36+ "postgrest" = ["test"];
37+ };
4138 ormolizedPackages = doCheck:
4239 pkgs.lib.mapAttrs (name: p: ormolize {
4340 package = p;
4441 inherit doCheck;
45− expectedFailures =
46− if pkgs.lib.lists.any (x: x == name) expectedFailures
47− then ./expected-failures + "/${name}.txt"
48− else null;
42+ excludedDirs =
43+ if builtins.hasAttr name excludedHackageDirs
44+ then excludedHackageDirs.${name}
45+ else [];
4946 }) haskellPackages;
5047in {
5148 ormolu = haskellPackages.ormolu;
52− # We put the derivations in another attribute set to avoid building them
53− # when nix-build is run.
54− dev = {
55− ormoluShell =
56− haskellPackages.shellFor {
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− };
49+ ormoluShell = haskellPackages.shellFor {
50+ packages = ps: [
51+ ps.ormolu
52+ ];
53+ buildInputs = [
54+ haskellPackages.cabal-install
55+ haskellPackages.ghcid
56+ ];
7257 };
7358 inherit ormoluOverlay ormoluCompiler;
7459 hackage = ormolizedPackages false;
7560 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
7661 let ps = [
77− "Agda"
7862 "QuickCheck"
7963 "ShellCheck"
8064 "aeson"
8165 "attoparsec"
8266 "aws"
83− "brick"
8467 "capability"
8568 "cassava"
8669 "conduit"
@@ -92,78 +75,37 @@ in {
9275 "hakyll"
9376 "haxl"
9477 "hedgehog"
95− "hledger"
9678 "hlint"
97− "http-client"
98− "idris"
99− "intero"
100− "leksah"
101− "lens"
10279 "megaparsec"
103− "optics"
10480 "ormolu"
105− "pandoc"
106− "parsec3"
107− "pipes"
81+ "optics"
10882 "postgrest"
109− "purescript"
11083 "servant"
11184 "servant-server"
112− "stack"
11385 "tensorflow"
11486 "text_1_2_4_0"
11587 "tls"
11688 "yesod-core"
89+
90+ # Comment idempotence issue
91+
92+ # "Agda"
93+ # "brick"
94+ # "hledger"
95+ # "http-client"
96+ # "idris"
97+ # "intero"
98+ # "leksah"
99+ # "pandoc"
100+ # "pipes"
101+ # "stack"
102+
103+ # Missing language extension
104+
105+ # "lens" #fixed in master
106+ # "purescript"
107+
117108 ];
118109 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
119110 );
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− };
169111}
expected-failures/Agda.txtdeleted−11
@@ -1,11 +0,0 @@
1−Formatting is not idempotent:
2− dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17
3− before: " = (check_ac"
4− after: " =\n "
5−Please, consider reporting the bug.
6−
7−Formatting is not idempotent:
8− src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4
9− before: " nes\n\n "
10− after: " nes\n\n -- Andreas"
11−Please, consider reporting the bug.
expected-failures/aws.txtdeleted−9
@@ -1,9 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− Examples/PutBucketNearLine.hs:5:1-6
3− parse error on input `import'
4−
5−The GHC parser (in Haddock mode) failed:
6− Examples/Sqs.hs:(88,3)-(90,4)
7− parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when
8− | the program ends as when it started.
9− -}'
expected-failures/distributed-process.txtdeleted−7
@@ -1,7 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− benchmarks/Channels.hs:2:1-6
3− parse error on input `import'
4−
5−The GHC parser (in Haddock mode) failed:
6− benchmarks/Spawns.hs:5:1-6
7− parse error on input `import'
expected-failures/esqueleto.txtdeleted−7
@@ -1,7 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− src/Database/Esqueleto/Internal/Internal.hs:379:1
3− lexical error in string/character literal at character 's'
4−
5−The GHC parser (in Haddock mode) failed:
6− test/PostgreSQL/Test.hs:562:9-41
7− parse error on input `-- | Check the result is not null'
expected-failures/fay.txtdeleted−18
@@ -1,18 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− examples/Separated.hs:12:1-6
3− parse error on input `module'
4−
5−The GHC parser (in Haddock mode) failed:
6− examples/calc.hs:(4,1)-(6,2)
7− parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs
8−-- You also need to download jquery.min.js.
9−--'
10−
11−The GHC parser (in Haddock mode) failed:
12− examples/canvaswater.hs:(6,1)-(7,17)
13− parse error on input `-- | A demonstration of Fay using the canvas element to display a
14−-- simple effect.'
15−
16−The GHC parser (in Haddock mode) failed:
17− examples/data.hs:9:1-6
18− parse error on input `module'
expected-failures/hlint.txtdeleted−11
@@ -1,11 +0,0 @@
1−Formatting is not idempotent:
2− src/Extension.hs<rendered>:19:22
3− before: "DoRec , -} Recursive"
4− after: "DoRec , -}\n "
5−Please, consider reporting the bug.
6−
7−Formatting is not idempotent:
8− src/Hint/Bracket.hs<rendered>:249:50
9− before: "\" x y [r]) {ideaSpan"
10− after: "\" x y [r])\n "
11−Please, consider reporting the bug.
expected-failures/idris.txtdeleted−7
@@ -1,7 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− src/Idris/Parser.hs:1052:1
3− parse error on input `@'
4−
5−The GHC parser (in Haddock mode) failed:
6− src/Idris/Parser/Expr.hs:75:1
7− parse error on input `@'
expected-failures/intero.txtdeleted−5
@@ -1,5 +0,0 @@
1−Formatting is not idempotent:
2− src/InteractiveUI.hs<rendered>:3748:33
3− before: "text \"Try\" <+> doWha"
4− after: "text \"Try\"\n "
5−Please, consider reporting the bug.
expected-failures/leksah.txtdeleted−5
@@ -1,5 +0,0 @@
1−Formatting is not idempotent:
2− src/IDE/Pane/Modules.hs<rendered>:1184:7
3− before: "cr\n -- show"
4− after: "cr\n in -- show"
5−Please, consider reporting the bug.
expected-failures/lens.txtdeleted−3
@@ -1,3 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− src/Control/Exception/Lens.hs:180:13-37
3− parse error on input `AllocationLimitExceeded__'
expected-failures/pandoc.txtdeleted−9
@@ -1,9 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− benchmark/weigh-pandoc.hs:14:1-6
3− parse error on input `import'
4−
5−Formatting is not idempotent:
6− src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:613:19
7− before: ".softbreak <$ endlin"
8− after: ".softbreak\n <$ en"
9−Please, consider reporting the bug.
expected-failures/pipes.txtdeleted−3
@@ -1,3 +0,0 @@
1−AST of input and AST of formatted code differ.
2− at src/Pipes/Core.hs:(128,1)-(151,2)
3−Please, consider reporting the bug.
expected-failures/postgrest.txtdeleted−5
@@ -1,5 +0,0 @@
1−Formatting is not idempotent:
2− src/PostgREST/DbRequestBuilder.hs<rendered>:149:24
3− before: " || -- clients"
4− after: " || ( origin ="
5−Please, consider reporting the bug.
expected-failures/purescript.txtdeleted−18
@@ -1,18 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− src/Language/PureScript/AST/Declarations.hs:479:1-17
3− Invalid type signature: pattern ValueDecl :: ...
4−Perhaps you meant to use PatternSynonyms?
5−
6−The GHC parser (in Haddock mode) failed:
7− src/Language/PureScript/AST/SourcePos.hs:99:1-22
8− Invalid type signature: pattern NullSourceSpan :: ...
9−Perhaps you meant to use PatternSynonyms?
10−
11−The GHC parser (in Haddock mode) failed:
12− src/Language/PureScript/Constants.hs:42:1-15
13− Invalid type signature: pattern Discard :: ...
14−Perhaps you meant to use PatternSynonyms?
15−
16−The GHC parser (in Haddock mode) failed:
17− src/Language/PureScript/Crash.hs:16:1-6
18− parse error on input `import'
expected-failures/tensorflow.txtdeleted−7
@@ -1,7 +0,0 @@
1−The GHC parser (in Haddock mode) failed:
2− tensorflow-mnist/app/Main.hs:50:13-14
3− parse error on input `->'
4−
5−The GHC parser (in Haddock mode) failed:
6− tensorflow-ops/tests/RegressionTest.hs:3:1-6
7− parse error on input `import'
format.sh+3−6
@@ -1,5 +1,5 @@
11#!/usr/bin/env nix-shell
2−#!nix-shell default.nix -A dev.withOrmolu -i bash --pure
2+#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure
33#
44# Format Ormolu using current version of Ormolu.
55
@@ -7,8 +7,5 @@ set -e
77
88export LANG="C.UTF-8"
99
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")
10+ormolu --mode inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
11+ormolu --mode inplace $(find tests -type f -name "*.hs")
nix/nixpkgs/default.nix+3−7
@@ -1,13 +1,9 @@
1−{ system ? builtins.currentSystem }:
21let
3− rev = "32b46dd897ab2143a609988a04d87452f0bbef59";
4− sha256 = "1gzfrpjnr1bz9zljsyg3a4zrhk8r927sz761mrgcg56dwinkhpjk";
2+ rev = "19.09";
3+ sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";
54 nixpkgs = builtins.fetchTarball {
65 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
76 inherit sha256;
87 };
9− pkgs = import nixpkgs {
10− inherit system;
11− config.allowUnfree = true;
12− };
8+ pkgs = import nixpkgs { config.allowUnfree = true; };
139in pkgs
nix/ormolize/default.nix+13−29
@@ -2,48 +2,32 @@
22, haskellPackages
33}:
44{ package
5−, expectedFailures ? null
65, 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− haskellPackages.ormolu
14− pkgs.diffutils
13+ (if doCheck
14+ then haskellPackages.ormolu
15+ else pkgs.haskell.lib.dontCheck haskellPackages.ormolu)
1516 pkgs.glibcLocales
1617 ];
1718 LANG = "en_US.UTF-8";
19+ excludedDirsRendered =
20+ if excludedDirs == []
21+ then ""
22+ else pkgs.lib.concatMapStringsSep " " (x: "-not -path './" + x + "/*'") excludedDirs;
1823 buildPhase = ''
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
24+ find . -name '*.hs' ${excludedDirsRendered} -exec bash ${./ormolize.sh} {} \; 2> log.txt
25+ cat log.txt
3626 '';
3727 inherit doCheck;
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− '';
28+ checkPhase = ''
29+ if [[ -s log.txt ]]; then exit 1; fi
30+ '';
4731 installPhase = ''
4832 mkdir "$out"
4933 find . -name '*.hs-original' -exec cp --parents {} $out \;
nix/ormolize/ormolize.shnew file+17
@@ -0,0 +1,17 @@
1+set -euo pipefail
2+
3+# drop includes
4+sed -i '/^#include/d' "$1"
5+
6+# deal with CPP in a fairly straightforward way
7+cpphs "$1" --noline > "$1-nocpp" 2> /dev/null
8+
9+# annoyingly, cpphs cannot modify files in place
10+mv "$1-nocpp" "$1"
11+
12+# preserve the original
13+cp "$1" "$1-original"
14+
15+# run ormolu
16+ormolu --tolerate-cpp --check-idempotency --mode inplace "$1" ||
17+ ormolu --tolerate-cpp --unsafe --mode inplace "$1"
ormolu.cabal+155−174
@@ -1,184 +1,165 @@
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
1+name: ormolu
2+version: 0.0.1.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
5754
5855source-repository head
59− type: git
60− location: https://github.com/tweag/ormolu.git
56+ type: git
57+ location: https://github.com/tweag/ormolu.git
6158
6259flag dev
63− description: Turn on development settings.
64− default: False
65− manual: True
60+ description: Turn on development settings.
61+ manual: True
62+ default: False
6663
6764library
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
111−
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
128−
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
137−
138−executable ormolu
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
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
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+ else
121+ ghc-options: -O2 -Wall
122+ default-language: Haskell2010
159123
160124test-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
125+ main-is: Spec.hs
126+ hs-source-dirs: tests
127+ type: exitcode-stdio-1.0
128+ build-depends: base >= 4.12 && < 5.0
129+ , containers >= 0.5 && < 0.7
130+ , filepath >= 1.2 && < 1.5
131+ , hspec >= 2.0 && < 3.0
132+ , ormolu
133+ , path >= 0.6 && < 0.7
134+ , path-io >= 1.4.2 && < 2.0
135+ , text >= 0.2 && < 1.3
136+ build-tools: hspec-discover >= 2.0 && < 3.0
137+ other-modules:
138+ Ormolu.Parser.PragmaSpec
139+ , Ormolu.PrinterSpec
168140
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
141+ if flag(dev)
142+ ghc-options: -Wall -Werror
143+ else
144+ ghc-options: -O2 -Wall
145+ default-language: Haskell2010
179146
180− if flag(dev)
181− ghc-options: -Wall -Werror
182−
183− else
184− ghc-options: -O2 -Wall
147+executable ormolu
148+ main-is: Main.hs
149+ hs-source-dirs: app
150+ build-depends: base >= 4.12 && < 5.0
151+ , ghc-lib-parser == 8.8.1
152+ , gitrev >= 1.3 && < 1.4
153+ , optparse-applicative >= 0.14 && < 0.15
154+ , ormolu
155+ , text >= 0.2 && < 1.3
156+ other-modules: Paths_ormolu
157+ if flag(dev)
158+ ghc-options: -Wall -Werror -Wcompat
159+ -Wincomplete-record-updates
160+ -Wincomplete-uni-patterns
161+ -Wnoncanonical-monad-instances
162+ -Wnoncanonical-monadfail-instances
163+ else
164+ ghc-options: -O2 -Wall
165+ default-language: Haskell2010
region-tests/expected-result-17-18.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo (
4− foo, bar, baz) where
5−
6−foo :: Int
7−foo = 5
8−
9−bar :: Int -> Int
10−bar = \case
11− 0 -> foo
12− x -> x - foo
13−
14−baz :: Int -> Int
15−baz = gege
16− where
17− gege = 1 + 2
region-tests/expected-result-6-7.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo (
4− foo, bar, baz) where
5−
6−foo :: Int
7−foo = 5
8−
9−bar :: Int -> Int
10−bar = \case
11− 0 -> foo
12− x -> x - foo
13−
14−baz :: Int -> Int
15−baz = gege
16− where
17− gege = 1 + 2
region-tests/expected-result-6-8.hsdeleted−16
@@ -1,16 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo (
4− foo, bar, baz) where
5−
6−foo :: Int
7−foo = 5
8−bar :: Int -> Int
9−bar = \case
10− 0 -> foo
11− x -> x - foo
12−
13−baz :: Int -> Int
14−baz = gege
15− where
16− gege = 1 + 2
region-tests/expected-result-9-12.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo (
4− foo, bar, baz) where
5−
6−foo :: Int
7−foo = 5
8−
9−bar :: Int -> Int
10−bar = \case
11− 0 -> foo
12− x -> x - foo
13−
14−baz :: Int -> Int
15−baz = gege
16− where
17− gege = 1 + 2
region-tests/expected-result-all.hsdeleted−21
@@ -1,21 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo
4− ( foo,
5− bar,
6− baz,
7− )
8−where
9−
10−foo :: Int
11−foo = 5
12−
13−bar :: Int -> Int
14−bar = \case
15− 0 -> foo
16− x -> x - foo
17−
18−baz :: Int -> Int
19−baz = gege
20− where
21− gege = 1 + 2
region-tests/src.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−
3−module Foo (
4− foo, bar, baz) where
5−
6−foo :: Int
7−foo = 5
8−
9−bar :: Int -> Int
10−bar = \case
11− 0 -> foo
12− x -> x - foo
13−
14−baz :: Int -> Int
15−baz = gege
16− where
17− gege = 1 + 2
shell.nix+2−4
@@ -1,5 +1,3 @@
1−{ pkgs ? (import ./nix/nixpkgs { inherit system; })
2−, system ? builtins.currentSystem
3−}:
1+{ pkgs ? (import ./nix/nixpkgs) }:
42
5−(import ./default.nix { inherit pkgs; }).dev.ormoluShell
3+(import ./default.nix { inherit pkgs; }).ormoluShell
src/GHC.hs+13−2
@@ -1,12 +1,23 @@
11module GHC
22 ( module X,
3+ ParsedSource,
34 )
45where
56
67import ApiAnnotation as X
78import BasicTypes as X
8−import GHC.Hs as X
9−import GHC.Hs.Instances 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
1019import Module as X
1120import RdrName as X
1221import SrcLoc as X
22+
23+type ParsedSource = Located (HsModule GhcPs)
src/GHC/DynFlags.hs+20−33
@@ -1,7 +1,5 @@
11{-# OPTIONS_GHC -Wno-missing-fields #-}
22
3−-- Modified from ghc-lib-api-ext.
4−
53module GHC.DynFlags
64 ( baseDynFlags,
75 )
@@ -10,40 +8,29 @@ where
108import Config
119import DynFlags
1210import Fingerprint
13−import GHC.Platform
14−import ToolSettings
11+import Platform
1512
13+-- | Taken from HLint.
1614fakeSettings :: Settings
17−fakeSettings =
18− Settings
19− { sGhcNameVersion =
20− GhcNameVersion
21− { ghcNameVersion_programName = "ghc",
22− ghcNameVersion_projectVersion = cProjectVersion
23− },
24− sFileSettings = FileSettings {},
25− sTargetPlatform =
26− Platform
27− { platformWordSize = PW8,
28− platformMini =
29− PlatformMini
30− { platformMini_arch = ArchUnknown,
31− platformMini_os = OSUnknown
32− },
33− platformUnregisterised = True
34− },
35− sPlatformMisc = PlatformMisc {},
36− sPlatformConstants =
37− PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},
38− sToolSettings =
39− ToolSettings
40− { toolSettings_opt_P_fingerprint = fingerprint0,
41− toolSettings_pgm_F = ""
42− }
43− }
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}
4431
45−fakeLlvmConfig :: LlvmConfig
46−fakeLlvmConfig = LlvmConfig [] []
32+fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
33+fakeLlvmConfig = ([], [])
4734
4835baseDynFlags :: DynFlags
4936baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
src/Ormolu.hs+19−19
@@ -1,4 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE RecordWildCards #-}
23
34-- | A formatter for Haskell source code.
45module Ormolu
@@ -6,7 +7,6 @@ module Ormolu
67 ormoluFile,
78 ormoluStdin,
89 Config (..),
9− RegionIndices (..),
1010 defaultConfig,
1111 DynOption (..),
1212 OrmoluException (..),
@@ -29,6 +29,7 @@ import Ormolu.Parser.Result
2929import Ormolu.Printer
3030import Ormolu.Utils (showOutputable)
3131import qualified SrcLoc as GHC
32+import System.IO (hGetContents, stdin)
3233
3334-- | Format a 'String', return formatted version as 'Text'.
3435--
@@ -43,27 +44,26 @@ import qualified SrcLoc as GHC
4344ormolu ::
4445 MonadIO m =>
4546 -- | Ormolu configuration
46− Config RegionIndices ->
47+ Config ->
4748 -- | Location of source file
4849 FilePath ->
4950 -- | Input to format
5051 String ->
5152 m Text
52−ormolu cfgWithIndices path str = do
53− let totalLines = length (lines str)
54− cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices
55− (warnings, result0) <-
53+ormolu cfg path str = do
54+ (ws, result0) <-
5655 parseModule' cfg OrmoluParsingFailed path str
5756 when (cfgDebug cfg) $ do
5857 traceM "warnings:\n"
59− traceM (concatMap showWarn warnings)
58+ traceM (concatMap showWarn ws)
6059 traceM (prettyPrintParseResult result0)
61− -- We're forcing 'txt' here because otherwise errors (such as messages
62− -- about not-yet-supported functionality) will be thrown later when we try
63− -- to parse the rendered code back, inside of GHC monad wrapper which will
64− -- lead to error messages presenting the exceptions as GHC bugs.
60+ -- NOTE We're forcing 'txt' here because otherwise errors (such as
61+ -- messages about not-yet-supported functionality) will be thrown later
62+ -- when we try to parse the rendered code back, inside of GHC monad
63+ -- wrapper which will lead to error messages presenting the exceptions as
64+ -- GHC bugs.
6565 let !txt = printModule result0
66− when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do
66+ when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do
6767 let pathRendered = path ++ "<rendered>"
6868 -- Parse the result of pretty-printing again and make sure that AST
6969 -- is the same as AST of original snippet module span positions.
@@ -79,7 +79,7 @@ ormolu cfgWithIndices path str = do
7979 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)
8080 -- Try re-formatting the formatted result to check if we get exactly
8181 -- the same output.
82− when (cfgCheckIdempotence cfg) $
82+ when (cfgCheckIdempotency cfg) $
8383 let txt2 = printModule result1
8484 in case diffText txt txt2 pathRendered of
8585 Nothing -> return ()
@@ -96,7 +96,7 @@ ormolu cfgWithIndices path str = do
9696ormoluFile ::
9797 MonadIO m =>
9898 -- | Ormolu configuration
99− Config RegionIndices ->
99+ Config ->
100100 -- | Location of source file
101101 FilePath ->
102102 -- | Resulting rendition
@@ -111,11 +111,11 @@ ormoluFile cfg path =
111111ormoluStdin ::
112112 MonadIO m =>
113113 -- | Ormolu configuration
114− Config RegionIndices ->
114+ Config ->
115115 -- | Resulting rendition
116116 m Text
117117ormoluStdin cfg =
118− liftIO getContents >>= ormolu cfg "<stdin>"
118+ liftIO (hGetContents stdin) >>= ormolu cfg "<stdin>"
119119
120120----------------------------------------------------------------------------
121121-- Helpers
@@ -124,7 +124,7 @@ ormoluStdin cfg =
124124parseModule' ::
125125 MonadIO m =>
126126 -- | Ormolu configuration
127− Config RegionDeltas ->
127+ Config ->
128128 -- | How to obtain 'OrmoluException' to throw when parsing fails
129129 (GHC.SrcSpan -> String -> OrmoluException) ->
130130 -- | File name to use in errors
@@ -133,10 +133,10 @@ parseModule' ::
133133 String ->
134134 m ([GHC.Warn], ParseResult)
135135parseModule' cfg mkException path str = do
136− (warnings, r) <- parseModule cfg path str
136+ (ws, r) <- parseModule cfg path str
137137 case r of
138138 Left (spn, err) -> liftIO $ throwIO (mkException spn err)
139− Right x -> return (warnings, x)
139+ Right x -> return (ws, x)
140140
141141-- | Pretty-print a 'GHC.Warn'.
142142showWarn :: GHC.Warn -> String
src/Ormolu/Config.hs+29−65
@@ -1,13 +1,11 @@
1−{-# LANGUAGE DeriveFunctor #-}
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE RecordWildCards #-}
34
45-- | Configuration options used by the tool.
56module Ormolu.Config
67 ( Config (..),
7− RegionIndices (..),
8− RegionDeltas (..),
98 defaultConfig,
10− regionIndicesToDeltas,
119 DynOption (..),
1210 dynOptionToLocatedStr,
1311 )
@@ -16,72 +14,38 @@ where
1614import qualified SrcLoc as GHC
1715
1816-- | Ormolu configuration.
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− }
17+data Config
18+ = Config
19+ { -- | Dynamic options to pass to GHC parser
20+ cfgDynOptions :: ![DynOption],
21+ -- | Do formatting faster but without automatic detection of defects
22+ cfgUnsafe :: !Bool,
23+ -- | Output information useful for debugging
24+ cfgDebug :: !Bool,
25+ -- | Do not fail if CPP pragma is present (still doesn't handle CPP but
26+ -- useful for formatting of files that enable the extension without
27+ -- actually containing CPP macros)
28+ cfgTolerateCpp :: !Bool,
29+ -- | Checks if re-formatting the result is idempotent.
30+ cfgCheckIdempotency :: !Bool
31+ }
4032 deriving (Eq, Show)
4133
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
34+-- | Default 'Config'.
35+defaultConfig :: Config
36+defaultConfig = Config
37+ { cfgDynOptions = [],
38+ cfgUnsafe = False,
39+ cfgDebug = False,
40+ cfgTolerateCpp = False,
41+ cfgCheckIdempotency = False
4942 }
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− }
8043
8144-- | A wrapper for dynamic options.
82−newtype DynOption = DynOption
83− { unDynOption :: String
84− }
45+newtype DynOption
46+ = DynOption
47+ { unDynOption :: String
48+ }
8549 deriving (Eq, Ord, Show)
8650
8751-- | Convert 'DynOption' to @'GHC.Located' 'String'@.
src/Ormolu/Diff.hs+17−25
@@ -1,4 +1,6 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
12{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
24
35-- | Diffing GHC ASTs modulo span positions.
46module Ormolu.Diff
@@ -8,14 +10,14 @@ module Ormolu.Diff
810 )
911where
1012
13+import BasicTypes (SourceText)
1114import Data.ByteString (ByteString)
1215import Data.Generics
1316import Data.Text (Text)
1417import qualified Data.Text as T
1518import qualified FastString as GHC
1619import GHC
17−import Ormolu.Imports (normalizeImports)
18−import Ormolu.Parser.CommentStream
20+import Ormolu.Imports (sortImports)
1921import Ormolu.Parser.Result
2022import Ormolu.Utils
2123
@@ -39,16 +41,14 @@ diffParseResult :: ParseResult -> ParseResult -> Diff
3941diffParseResult
4042 ParseResult
4143 { prCommentStream = cstream0,
42− prParsedSource = hs0
44+ prParsedSource = ps0
4345 }
4446 ParseResult
4547 { prCommentStream = cstream1,
46− prParsedSource = hs1
48+ prParsedSource = ps1
4749 } =
4850 matchIgnoringSrcSpans cstream0 cstream1
49− <> matchIgnoringSrcSpans
50− hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}
51− hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}
51+ <> matchIgnoringSrcSpans ps0 ps1
5252
5353-- | Compare two values for equality disregarding differences in 'SrcSpan's
5454-- and the ordering of import lists.
@@ -57,7 +57,7 @@ matchIgnoringSrcSpans = genericQuery
5757 where
5858 genericQuery :: GenericQ (GenericQ Diff)
5959 genericQuery x y
60− -- 'ByteString' implements 'Data' instance manually and does not
60+ -- NOTE 'ByteString' implement 'Data' instance manually and does not
6161 -- implement 'toConstr', so we have to deal with it in a special way.
6262 | Just x' <- cast x,
6363 Just y' <- cast y =
@@ -70,10 +70,9 @@ matchIgnoringSrcSpans = genericQuery
7070 gzipWithQ
7171 ( genericQuery
7272 `extQ` srcSpanEq
73− `extQ` commentEq
73+ `extQ` hsModuleEq
7474 `extQ` sourceTextEq
7575 `extQ` hsDocStringEq
76− `extQ` importDeclQualifiedStyleEq
7776 `ext2Q` forLocated
7877 )
7978 x
@@ -81,23 +80,16 @@ matchIgnoringSrcSpans = genericQuery
8180 | otherwise = Different []
8281 srcSpanEq :: SrcSpan -> GenericQ Diff
8382 srcSpanEq _ _ = Same
84− commentEq :: Comment -> GenericQ Diff
85− commentEq (Comment _ x) d =
86− case cast d :: Maybe Comment of
83+ hsModuleEq :: HsModule GhcPs -> GenericQ Diff
84+ hsModuleEq hs0 hs1' =
85+ case cast hs1' :: Maybe (HsModule GhcPs) of
8786 Nothing -> Different []
88− Just (Comment _ y) ->
89− if x == y
90− then Same
91− else Different []
87+ Just hs1 ->
88+ matchIgnoringSrcSpans
89+ hs0 {hsmodImports = sortImports (hsmodImports hs0)}
90+ hs1 {hsmodImports = sortImports (hsmodImports hs1)}
9291 sourceTextEq :: SourceText -> GenericQ Diff
9392 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 []
10193 hsDocStringEq :: HsDocString -> GenericQ Diff
10294 hsDocStringEq str0 str1' =
10395 case cast str1' :: Maybe HsDocString of
@@ -115,7 +107,7 @@ matchIgnoringSrcSpans = genericQuery
115107 appendSpan :: SrcSpan -> Diff -> Diff
116108 appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
117109 where
118− fresh = not $ any (`isSubspanOf` s) ss
110+ fresh = not $ any (flip isSubspanOf s) ss
119111 helpful = isGoodSrcSpan s
120112 appendSpan _ d = d
121113
src/Ormolu/Exception.hs+19−24
@@ -8,8 +8,6 @@ module Ormolu.Exception
88where
99
1010import Control.Exception
11−import Data.List.NonEmpty (NonEmpty (..))
12−import qualified Data.List.NonEmpty as NE
1311import Data.Text (Text)
1412import qualified GHC
1513import Ormolu.Utils (showOutputable)
@@ -19,7 +17,9 @@ import System.IO
1917
2018-- | Ormolu exception representing all cases when Ormolu can fail.
2119data OrmoluException
22− = -- | Parsing of original source code failed
20+ = -- | Ormolu does not work with source files that use CPP
21+ OrmoluCppEnabled FilePath
22+ | -- | Parsing of original source code failed
2323 OrmoluParsingFailed GHC.SrcSpan String
2424 | -- | Parsing of formatted source code failed
2525 OrmoluOutputParsingFailed GHC.SrcSpan String
@@ -27,14 +27,17 @@ data OrmoluException
2727 OrmoluASTDiffers FilePath [GHC.SrcSpan]
2828 | -- | Formatted source code is not idempotent
2929 OrmoluNonIdempotentOutput GHC.RealSrcLoc Text Text
30− | -- | Some GHC options were not recognized
31− OrmoluUnrecognizedOpts (NonEmpty String)
3230 deriving (Eq, Show)
3331
3432instance Exception OrmoluException where
3533 displayException = \case
34+ OrmoluCppEnabled path ->
35+ unlines
36+ [ "CPP is not supported:",
37+ withIndent path
38+ ]
3639 OrmoluParsingFailed s e ->
37− showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]
40+ showParsingErr "Parsing of source code failed:" s [e]
3841 OrmoluOutputParsingFailed s e ->
3942 showParsingErr "Parsing of formatted code failed:" s [e]
4043 ++ "Please, consider reporting the bug.\n"
@@ -42,12 +45,10 @@ instance Exception OrmoluException where
4245 unlines $
4346 [ "AST of input and AST of formatted code differ."
4447 ]
45− ++ fmap
46− withIndent
47− ( case fmap (\s -> "at " ++ showOutputable s) ss of
48− [] -> ["in " ++ path]
49− xs -> xs
50− )
48+ ++ ( fmap withIndent $ case fmap (\s -> "at " ++ showOutputable s) ss of
49+ [] -> ["in " ++ path]
50+ xs -> xs
51+ )
5152 ++ ["Please, consider reporting the bug."]
5253 OrmoluNonIdempotentOutput loc left right ->
5354 showParsingErr
@@ -55,11 +56,6 @@ instance Exception OrmoluException where
5556 loc
5657 ["before: " ++ show left, "after: " ++ show right]
5758 ++ "Please, consider reporting the bug.\n"
58− OrmoluUnrecognizedOpts opts ->
59− unlines
60− [ "The following GHC options were not recognized:",
61− (withIndent . unwords . NE.toList) opts
62− ]
6359
6460-- | Inside this wrapper 'OrmoluException' will be caught and displayed
6561-- nicely using 'displayException'.
@@ -74,13 +70,12 @@ withPrettyOrmoluExceptions m = m `catch` h
7470 hPutStrLn stderr (displayException e)
7571 exitWith . ExitFailure $
7672 case e of
77− -- Error code 1 is for 'error' or 'notImplemented'
78− -- 2 used to be for erroring out on CPP
79− OrmoluParsingFailed {} -> 3
80− OrmoluOutputParsingFailed {} -> 4
81− OrmoluASTDiffers {} -> 5
82− OrmoluNonIdempotentOutput {} -> 6
83− OrmoluUnrecognizedOpts {} -> 7
73+ -- Error code 1 is for `error` or `notImplemented`
74+ OrmoluCppEnabled _ -> 2
75+ OrmoluParsingFailed _ _ -> 3
76+ OrmoluOutputParsingFailed _ _ -> 4
77+ OrmoluASTDiffers _ _ -> 5
78+ OrmoluNonIdempotentOutput _ _ _ -> 6
8479
8580----------------------------------------------------------------------------
8681-- Helpers
src/Ormolu/Imports.hs+51−172
@@ -1,202 +1,81 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE RecordWildCards #-}
43
54-- | Manipulations on import lists.
65module Ormolu.Imports
7− ( normalizeImports,
6+ ( sortImports,
87 )
98where
109
1110import Data.Bifunctor
12−import Data.Char (isAlphaNum)
1311import Data.Function (on)
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)
12+import Data.Generics (gcompare)
13+import Data.List (sortBy)
1814import GHC hiding (GhcPs, IE)
19−import GHC.Hs.Extension
20−import GHC.Hs.ImpExp (IE (..))
21−import Ormolu.Utils (notImplemented, showOutputable)
15+import HsExtension
16+import HsImpExp (IE (..))
17+import Ormolu.Utils (notImplemented)
2218
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))
19+-- | Sort imports by module name. This also sorts explicit import lists for
20+-- each declaration.
21+sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
22+sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)
3023 where
31− g (L l ImportDecl {..}) =
32− L
33− l
34− ImportDecl
35− { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,
36− ..
37− }
38− g _ = notImplemented "XImportDecl"
24+ sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs
25+ sortImportLists decl =
26+ decl
27+ { ideclHiding = second (fmap sortLies) <$> ideclHiding decl
28+ }
3929
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− }
30+-- | Compare two @'LImportDecl' 'GhcPs'@ things.
31+compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering
32+compareIdecl (L _ m0) (L _ m1) =
33+ case (isPrelude n0, isPrelude n1) of
34+ (False, False) -> n0 `compare` n1
35+ (True, False) -> GT
36+ (False, True) -> LT
37+ (True, True) -> m0 `gcompare` m1
9138 where
92− isPrelude = moduleNameString moduleName == "Prelude"
93− moduleName = unLoc ideclName
94−importId _ = notImplemented "XImportDecl"
39+ n0 = unLoc (ideclName m0)
40+ n1 = unLoc (ideclName m1)
41+ isPrelude = (== "Prelude") . moduleNameString
9542
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
43+-- | Sort located import or export.
44+sortLies :: [LIE GhcPs] -> [LIE GhcPs]
45+sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)
15146
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)
47+-- | Sort imports\/exports inside of 'IEThingWith'.
48+sortThings :: IE GhcPs -> IE GhcPs
49+sortThings = \case
50+ IEThingWith NoExt x w xs fl ->
51+ IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl
52+ other -> other
15653
157−instance Ord IEWrappedNameOrd where
158− compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y
54+-- | Compare two located imports or exports.
55+compareIE :: IE GhcPs -> IE GhcPs -> Ordering
56+compareIE = compareIewn `on` getIewn
15957
16058-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.
161−getIewn :: IE GhcPs -> IEWrappedNameOrd
59+getIewn :: IE GhcPs -> IEWrappedName RdrName
16260getIewn = \case
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
61+ IEVar NoExt x -> unLoc x
62+ IEThingAbs NoExt x -> unLoc x
63+ IEThingAll NoExt x -> unLoc x
64+ IEThingWith NoExt x _ _ _ -> unLoc x
65+ IEModuleContents NoExt _ -> notImplemented "IEModuleContents"
66+ IEGroup NoExt _ _ -> notImplemented "IEGroup"
67+ IEDoc NoExt _ -> notImplemented "IEDoc"
68+ IEDocNamed NoExt _ -> notImplemented "IEDocNamed"
69+ XIE NoExt -> notImplemented "XIE"
17670
17771-- | Compare two @'IEWrapppedName' 'RdrName'@ things.
17872compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering
179−compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y
73+compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y
18074compareIewn (IEName _) (IEPattern _) = LT
18175compareIewn (IEName _) (IEType _) = LT
18276compareIewn (IEPattern _) (IEName _) = GT
183−compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y
77+compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y
18478compareIewn (IEPattern _) (IEType _) = LT
18579compareIewn (IEType _) (IEName _) = GT
18680compareIewn (IEType _) (IEPattern _) = GT
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
81+compareIewn (IEType x) (IEType y) = unLoc x `compare` unLoc y
src/Ormolu/Parser.hs+68−99
@@ -1,5 +1,6 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE StandaloneDeriving #-}
34{-# OPTIONS_GHC -fno-warn-orphans #-}
45
56-- | Parser for Haskell source code.
@@ -9,16 +10,14 @@ module Ormolu.Parser
910 )
1011where
1112
12−import Bag (bagToList)
1313import qualified CmdLineParser as GHC
1414import Control.Exception
15+import Control.Monad
1516import Control.Monad.IO.Class
16−import qualified Data.List as L
17−import qualified Data.List.NonEmpty as NE
18−import Data.Ord (Down (Down))
19−import qualified Data.Text as T
17+import Data.List ((\\), foldl', isPrefixOf)
18+import Data.Maybe (catMaybes)
19+import qualified DynFlags as GHC
2020import DynFlags as GHC
21−import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
2221import qualified FastString as GHC
2322import GHC hiding (IE, UnicodeSyntax)
2423import GHC.DynFlags (baseDynFlags)
@@ -31,8 +30,7 @@ import Ormolu.Exception
3130import Ormolu.Parser.Anns
3231import Ormolu.Parser.CommentStream
3332import Ormolu.Parser.Result
34−import Ormolu.Processing.Preprocess (preprocess)
35−import Ormolu.Utils (incSpanLine, removeIndentation)
33+import qualified Outputable as GHC
3634import qualified Panic as GHC
3735import qualified Parser as GHC
3836import qualified StringBuffer as GHC
@@ -41,7 +39,7 @@ import qualified StringBuffer as GHC
4139parseModule ::
4240 MonadIO m =>
4341 -- | Ormolu configuration
44− Config RegionDeltas ->
42+ Config ->
4543 -- | File name (only for source location annotations)
4644 FilePath ->
4745 -- | Input for parser
@@ -50,20 +48,17 @@ parseModule ::
5048 ( [GHC.Warn],
5149 Either (SrcSpan, String) ParseResult
5250 )
53−parseModule Config {..} path rawInput = liftIO $ do
54− let (literalPrefix, indentedInput, literalSuffix, extraComments) =
55− preprocess path rawInput cfgRegion
56− (input, indent) = removeIndentation indentedInput
57− -- It's important that 'setDefaultExts' is done before
51+parseModule Config {..} path input' = liftIO $ do
52+ let (input, extraComments) = stripLinePragmas path input'
53+ -- NOTE It's important that 'setDefaultExts' is done before
5854 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
5955 -- extension that was explicitly disabled in the file.
6056 let baseFlags =
6157 GHC.setGeneralFlag'
6258 GHC.Opt_Haddock
6359 (setDefaultExts baseDynFlags)
64− extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
6560 (warnings, dynFlags) <-
66− parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case
61+ parsePragmasIntoDynFlags baseFlags path input' >>= \case
6762 Right res -> pure res
6863 Left err ->
6964 let loc =
@@ -71,59 +66,21 @@ parseModule Config {..} path rawInput = liftIO $ do
7166 (mkSrcLoc (GHC.mkFastString path) 1 1)
7267 (mkSrcLoc (GHC.mkFastString path) 1 1)
7368 in throwIO (OrmoluParsingFailed loc err)
74− let useRecordDot =
75− "record-dot-preprocessor" == pgm_F dynFlags
76− || any
77− (("RecordDotPreprocessor" ==) . moduleNameString)
78− (pluginModNames dynFlags)
79− pStateErrors = \pstate ->
80− let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
81− fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)
82− in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of
83− [] -> Nothing
84− err : _ ->
85− -- Show instance returns a short error message
86− Just (fixupErrSpan (errMsgSpan err), show err)
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− }
69+ when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
70+ throwIO (OrmoluCppEnabled path)
71+ let r = case runParser GHC.parseModule dynFlags path input of
72+ GHC.PFailed _ ss m ->
73+ Left (ss, GHC.showSDoc dynFlags m)
74+ GHC.POk pstate pmod ->
75+ let (comments, exts) = mkCommentStream extraComments pstate
76+ in Right ParseResult
77+ { prParsedSource = pmod,
78+ prAnns = mkAnns pstate,
79+ prCommentStream = comments,
80+ prExtensions = exts
81+ }
11782 return (warnings, r)
11883
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−
12784-- | Extensions that are not enabled automatically and should be activated
12885-- by user.
12986manualExts :: [Extension]
@@ -143,13 +100,14 @@ manualExts =
143100 MonadComprehensions,
144101 UnboxedSums,
145102 UnicodeSyntax, -- gives special meanings to operators like (→)
146− TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this
103+ TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
147104 -- apparently interferes with QuasiQuotes in
148105 -- weird ways
149− ImportQualifiedPost -- affects how Ormolu renders imports, so the
150− -- decision of enabling this style is left to the user
151106 ]
152107
108+----------------------------------------------------------------------------
109+-- Helpers (taken from ghc-exactprint)
110+
153111-- | Run a 'GHC.P' computation.
154112runParser ::
155113 -- | Computation to run
@@ -168,47 +126,58 @@ runParser parser flags filename input = GHC.unP parser parseState
168126 buffer = GHC.stringToStringBuffer input
169127 parseState = GHC.mkPState flags buffer location
170128
171−-- | Wrap GHC's 'Severity' to add 'Ord' instance.
172−newtype SeverityOrd = SeverityOrd Severity
129+-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
130+-- comments.
131+stripLinePragmas :: FilePath -> String -> (String, [Located String])
132+stripLinePragmas path = unlines' . unzip . findLines path . lines
133+ where
134+ unlines' (a, b) = (unlines a, catMaybes b)
173135
174−instance Eq SeverityOrd where
175− s1 == s2 = compare s1 s2 == EQ
136+findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
137+findLines path = zipWith (checkLine path) [1 ..]
176138
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
139+checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
140+checkLine path line s
141+ | "{-# LINE" `isPrefixOf` s =
142+ let (pragma, res) = getPragma s
143+ size = length pragma
144+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
145+ in (res, Just $ L ss pragma)
146+ | "#!" `isPrefixOf` s =
147+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
148+ in ("", Just $ L ss s)
149+ | otherwise = (s, Nothing)
150+ where
151+ mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
152+
153+getPragma :: String -> (String, String)
154+getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
155+getPragma s@(x : xs)
156+ | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
157+ | otherwise =
158+ let (prag, remline) = getPragma xs
159+ in (x : prag, ' ' : remline)
160+
161+-- | Enable all language extensions that we think should be enabled by
162+-- default for ease of use.
163+setDefaultExts :: DynFlags -> DynFlags
164+setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
165+ where
166+ autoExts = allExts \\ manualExts
167+ allExts = [minBound .. maxBound]
189168
190169----------------------------------------------------------------------------
191−-- Helpers taken from HLint
170+-- More helpers (taken from HLint)
192171
193172parsePragmasIntoDynFlags ::
194− -- | Pre-set 'DynFlags'
195173 DynFlags ->
196− -- | Extra options (provided by user)
197− [Located String] ->
198− -- | File name (only for source location annotations)
199174 FilePath ->
200− -- | Input for parser
201175 String ->
202176 IO (Either String ([GHC.Warn], DynFlags))
203−parsePragmasIntoDynFlags flags extraOpts filepath str =
177+parsePragmasIntoDynFlags flags filepath str =
204178 catchErrors $ do
205179 let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath
206− (flags', leftovers, warnings) <-
207− parseDynamicFilePragma flags (opts <> extraOpts)
208− case NE.nonEmpty leftovers of
209− Nothing -> return ()
210− Just unrecognizedOpts ->
211− throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts))
180+ (flags', _, warnings) <- parseDynamicFilePragma flags opts
212181 let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream
213182 return $ Right (warnings, flags'')
214183 where
src/Ormolu/Parser/CommentStream.hs+64−152
@@ -1,77 +1,79 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE GeneralizedNewtypeDeriving #-}
34{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE TupleSections #-}
46
57-- | Functions for working with comment stream.
68module Ormolu.Parser.CommentStream
7− ( -- * Comment stream
8− CommentStream (..),
9− mkCommentStream,
10− showCommentStream,
11−
12− -- * Comment
9+ ( CommentStream (..),
1310 Comment (..),
14− unComment,
15− hasAtomsBefore,
11+ mkCommentStream,
12+ isPrevHaddock,
1613 isMultilineComment,
14+ showCommentStream,
1715 )
1816where
1917
2018import Data.Char (isSpace)
2119import Data.Data (Data)
22−import qualified Data.List as L
20+import Data.Either (partitionEithers)
21+import Data.List (dropWhileEnd, isPrefixOf, sortOn)
2322import Data.List.NonEmpty (NonEmpty (..))
2423import qualified Data.List.NonEmpty as NE
2524import Data.Maybe (mapMaybe)
2625import qualified GHC
2726import qualified Lexer as GHC
2827import Ormolu.Parser.Pragma
29−import Ormolu.Parser.Shebang
30−import Ormolu.Processing.Common
31−import Ormolu.Utils (onTheSameLine, showOutputable)
28+import Ormolu.Utils (showOutputable)
3229import SrcLoc
3330
34−----------------------------------------------------------------------------
35−-- Comment stream
36−
3731-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to
3832-- beginning of corresponding spans.
3933newtype CommentStream = CommentStream [RealLocated Comment]
4034 deriving (Eq, Data, Semigroup, Monoid)
4135
42−-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are
43−-- removed from the 'CommentStream'. Shebangs are only extracted from the
44−-- comments that come from the first argument.
36+-- | A wrapper for a single comment. The 'NonEmpty' list inside contains
37+-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.
38+newtype Comment = Comment (NonEmpty String)
39+ deriving (Eq, Show, Data)
40+
41+-- | Create 'CommentStream' from 'GHC.PState'. We also create a 'Set' of
42+-- extensions here, which is not sorted in any way. The pragma comment are
43+-- removed from the 'CommentStream'.
4544mkCommentStream ::
46− -- | Original input
47− String ->
4845 -- | Extra comments to include
4946 [Located String] ->
5047 -- | Parser state to use for comment extraction
5148 GHC.PState ->
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,
61− pragmas,
62− CommentStream comments
49+ -- | Comment stream and a set of extracted pragmas
50+ (CommentStream, [Pragma])
51+mkCommentStream extraComments pstate =
52+ ( CommentStream $
53+ -- NOTE It's easier to normalize pragmas right when we construct comment
54+ -- streams. Because this way we need to do it only once and when we
55+ -- perform checking later they'll automatically match.
56+ mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,
57+ pragmas
6358 )
6459 where
65− (comments, pragmas) = extractPragmas input rawComments1
66− (rawComments1, mstackHeader) = extractStackHeader rawComments0
67− rawComments0 =
68− L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $
69− otherExtraComments
60+ (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)
61+ rawComments =
62+ mapMaybe toRealSpan $
63+ extraComments
7064 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)
7165 ++ concatMap
7266 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
7367 (GHC.annotations_comments pstate)
74− (shebangs, otherExtraComments) = extractShebangs extraComments
68+
69+-- | Test whether a 'Comment' looks like a Haddock following a definition,
70+-- i.e. something starting with @-- ^@.
71+isPrevHaddock :: Comment -> Bool
72+isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
73+
74+-- | Is this comment multiline-style?
75+isMultilineComment :: Comment -> Bool
76+isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
7577
7678-- | Pretty-print a 'CommentStream'.
7779showCommentStream :: CommentStream -> String
@@ -82,117 +84,28 @@ showCommentStream (CommentStream xs) =
8284 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
8385
8486----------------------------------------------------------------------------
85−-- Comment
86−
87−-- | A wrapper for a single comment. The 'Bool' indicates whether there were
88−-- atoms before beginning of the comment in the original input. The
89−-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or
90−-- just single item\/line otherwise.
91−data Comment = Comment Bool (NonEmpty String)
92− deriving (Eq, Show, Data)
87+-- Helpers
9388
9489-- | Normalize comment string. Sometimes one multi-line comment is turned
9590-- into several lines for subsequent outputting with correct indentation for
9691-- each line.
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)
92+mkComment :: RealLocated String -> RealLocated Comment
93+mkComment (L l s) =
94+ L l . Comment . fmap dropTrailing $
95+ if "{-" `isPrefixOf` s
96+ then case NE.nonEmpty (lines s) of
97+ Nothing -> s :| []
98+ Just (x :| xs) ->
99+ let getIndent y =
100+ if all isSpace y
101+ then startIndent
102+ else length (takeWhile isSpace y)
103+ n = minimum (startIndent : fmap getIndent xs)
104+ in x :| (drop n <$> xs)
105+ else s :| []
105106 where
106− comment =
107− L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $
108− if "{-" `L.isPrefixOf` s
109− then case NE.nonEmpty (lines s) of
110− Nothing -> s :| []
111− Just (x :| xs) ->
112− let getIndent y =
113− if all isSpace y || y == endDisabling
114− then startIndent
115− else length (takeWhile isSpace y)
116− n = minimum (startIndent : fmap getIndent xs)
117− removeIndent y =
118− if y == endDisabling
119− then y
120− else drop n y
121− in x :| (removeIndent <$> xs)
122− else s :| []
123− (atomsBefore, ls') =
124− case dropWhile ((< commentLine) . fst) ls of
125− [] -> (False, [])
126− ((_, i) : ls'') ->
127− case take 2 (dropWhile isSpace i) of
128− "--" -> (False, ls'')
129− "{-" -> (False, ls'')
130− _ -> (True, ls'')
131− dropTrailing = L.dropWhileEnd isSpace
107+ dropTrailing = dropWhileEnd isSpace
132108 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
196109
197110-- | Get a 'String' from 'GHC.AnnotationComment'.
198111unAnnotationComment :: GHC.AnnotationComment -> Maybe String
@@ -214,13 +127,12 @@ toRealSpan :: Located a -> Maybe (RealLocated a)
214127toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
215128toRealSpan _ = Nothing
216129
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
130+-- | If a given comment is a pragma, return it in parsed form in 'Right'.
131+-- Otherwise return the original comment unchanged.
132+partitionComments ::
133+ RealLocated String ->
134+ Either (RealLocated String) Pragma
135+partitionComments input =
136+ case parsePragma (unRealSrcSpan input) of
137+ Nothing -> Left input
138+ Just pragma -> Right pragma
src/Ormolu/Parser/Pragma.hs+5−5
@@ -10,7 +10,7 @@ where
1010
1111import Control.Monad
1212import Data.Char (isSpace, toLower)
13−import qualified Data.List as L
13+import Data.List
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 <- L.stripPrefix "{-#" input
39− guard ("#-}" `L.isSuffixOf` input)
38+ inputNoPrefix <- stripPrefix "{-#" input
39+ guard ("#-}" `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 = L.dropWhileEnd isSpace . dropWhile isSpace
49+ trimSpaces = 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.
@@ -54,7 +54,7 @@ parseExtensions :: String -> Maybe [String]
5454parseExtensions str = tokenize str >>= go
5555 where
5656 go = \case
57− [L.ITconid ext] -> return [unpackFS ext]
57+ (L.ITconid ext : []) -> return [unpackFS ext]
5858 (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs
5959 _ -> Nothing
6060
src/Ormolu/Parser/Result.hs+11−26
@@ -7,38 +7,23 @@ module Ormolu.Parser.Result
77 )
88where
99
10−import Data.Text (Text)
1110import GHC
1211import Ormolu.Parser.Anns
1312import Ormolu.Parser.CommentStream
1413import Ormolu.Parser.Pragma (Pragma)
15−import Ormolu.Parser.Shebang (Shebang)
1614
1715-- | A collection of data that represents a parsed module in Ormolu.
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− }
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+ }
4227
4328-- | Pretty-print a 'ParseResult'.
4429prettyPrintParseResult :: ParseResult -> String
src/Ormolu/Parser/Shebang.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−
3−-- | A module for dealing with shebangs.
4−module Ormolu.Parser.Shebang
5− ( Shebang (..),
6− extractShebangs,
7− isShebang,
8− )
9−where
10−
11−import Data.Data (Data)
12−import qualified Data.List as L
13−import SrcLoc
14−
15−-- | A wrapper for a shebang.
16−newtype Shebang = Shebang (Located String)
17− deriving (Eq, Data)
18−
19−-- | Extract shebangs from the beginning of a comment stream.
20−extractShebangs :: [Located String] -> ([Shebang], [Located String])
21−extractShebangs comments = (Shebang <$> shebangs, rest)
22− where
23− (shebangs, rest) = span (isShebang . unLoc) comments
24−
25−-- | Return 'True' if given 'String' is a shebang.
26−isShebang :: String -> Bool
27−isShebang str = "#!" `L.isPrefixOf` str
src/Ormolu/Printer.hs+7−17
@@ -1,3 +1,5 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
13{-# LANGUAGE RecordWildCards #-}
24
35-- | Pretty-printer for Haskell AST.
@@ -11,7 +13,6 @@ import Ormolu.Parser.Result
1113import Ormolu.Printer.Combinators
1214import Ormolu.Printer.Meat.Module
1315import Ormolu.Printer.SpanStream
14−import Ormolu.Processing.Postprocess (postprocess)
1516
1617-- | Render a module.
1718printModule ::
@@ -20,19 +21,8 @@ printModule ::
2021 -- | Resulting rendition
2122 Text
2223printModule ParseResult {..} =
23− prLiteralPrefix <> region <> prLiteralSuffix
24− where
25− region =
26− postprocess prIndent $
27− runR
28− ( p_hsModule
29− prStackHeader
30− prShebangs
31− prPragmas
32− prImportQualifiedPost
33− prParsedSource
34− )
35− (mkSpanStream prParsedSource)
36− prCommentStream
37− prAnns
38− prUseRecordDot
24+ runR
25+ (p_hsModule prExtensions prParsedSource)
26+ (mkSpanStream prParsedSource)
27+ prCommentStream
28+ prAnns
src/Ormolu/Printer/Combinators.hs+54−39
@@ -2,6 +2,7 @@
22{-# LANGUAGE GADTs #-}
33{-# LANGUAGE LambdaCase #-}
44{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
56
67-- | Printing combinators. The definitions here are presented in such an
78-- order so you can just go through the Haddocks and by the end of the file
@@ -21,9 +22,9 @@ module Ormolu.Printer.Combinators
2122 space,
2223 newline,
2324 inci,
24− inciIf,
2525 located,
2626 located',
27+ locatedPat,
2728 switchLayout,
2829 Layout (..),
2930 vlayout,
@@ -52,57 +53,58 @@ module Ormolu.Printer.Combinators
5253
5354 -- ** Literals
5455 comma,
55− commaDel,
56− equals,
5756
58− -- ** Stateful markers
59− SpanMark (..),
60− spanMarkSpan,
57+ -- ** Comments
6158 HaddockStyle (..),
62− setSpanMark,
63− getSpanMark,
59+ setLastCommentSpan,
60+ getLastCommentSpan,
6461 )
6562where
6663
6764import Control.Monad
65+import Data.Data (Data)
6866import Data.List (intersperse)
6967import Data.Text (Text)
68+import GHC (Pat (XPat), XXPat)
7069import Ormolu.Printer.Comments
7170import Ormolu.Printer.Internal
71+import Ormolu.Utils (isModule)
7272import SrcLoc
7373
7474----------------------------------------------------------------------------
7575-- Basic
7676
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−
8677-- | Enter a 'Located' entity. This combinator handles outputting comments
8778-- and sets layout (single-line vs multi-line) for the inner computation.
8879-- Roughly, the rule for using 'located' is that every time there is a
8980-- 'Located' wrapper, it should be “discharged” with a corresponding
9081-- 'located' invocation.
9182located ::
83+ Data a =>
9284 -- | Thing to enter
9385 Located a ->
9486 -- | How to render inner value
9587 (a -> R ()) ->
9688 R ()
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
89+located loc f = do
90+ let withRealLocated (L l a) g =
91+ case l of
92+ UnhelpfulSpan _ -> return ()
93+ RealSrcSpan l' -> g (L l' a)
94+ withRealLocated loc spitPrecedingComments
95+ let setEnclosingSpan =
96+ case getLoc loc of
97+ UnhelpfulSpan _ -> id
98+ RealSrcSpan orf ->
99+ if isModule (unLoc loc)
100+ then id
101+ else withEnclosingSpan orf
102+ setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))
103+ withRealLocated loc spitFollowingComments
103104
104105-- | A version of 'located' with arguments flipped.
105106located' ::
107+ Data a =>
106108 -- | How to render inner value
107109 (a -> R ()) ->
108110 -- | Thing to enter
@@ -110,6 +112,28 @@ located' ::
110112 R ()
111113located' = flip located
112114
115+-- | A version of 'located' that works on 'Pat'.
116+--
117+-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always
118+-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.
119+--
120+-- Most of the time, we can just use 'p_pat' directly, because it handles
121+-- located 'Pat's. However, sometimes we want to use the location to render
122+-- something other than the given 'Pat'.
123+--
124+-- If given 'Pat' does not contain a location, we error out.
125+--
126+-- This should become unnecessary if
127+-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.
128+locatedPat ::
129+ (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>
130+ Pat pass ->
131+ (Pat pass -> R ()) ->
132+ R ()
133+locatedPat p f = case p of
134+ XPat pat -> located pat f
135+ _ -> error "locatedPat: Pat does not contain a location"
136+
113137-- | Set layout according to combination of given 'SrcSpan's for a given.
114138-- Use this only when you need to set layout based on e.g. combined span of
115139-- several elements when there is no corresponding 'Located' wrapper
@@ -185,12 +209,10 @@ sepSemi f xs = vlayout singleLine multiLine
185209 xs' ->
186210 if ub
187211 then do
188− txt "{"
189− space
190− sep (txt ";" >> space) (dontUseBraces . f) xs'
191− space
192− txt "}"
193− else sep (txt ";" >> space) f xs'
212+ txt "{ "
213+ sep (txt "; ") (dontUseBraces . f) xs'
214+ txt " }"
215+ else sep (txt "; ") f xs'
194216 multiLine =
195217 sep newline (dontUseBraces . f) xs
196218
@@ -203,7 +225,6 @@ data BracketStyle
203225 N
204226 | -- | Shifted one level
205227 S
206− deriving (Eq, Show)
207228
208229-- | Surround given entity by backticks.
209230backticks :: R () -> R ()
@@ -280,7 +301,9 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
280301 then newline >> inci m
281302 else space >> sitcc m
282303 newline
283− inciIf (style == S) (txt close)
304+ case style of
305+ N -> txt close
306+ S -> inci (txt close)
284307
285308----------------------------------------------------------------------------
286309-- Literals
@@ -288,11 +311,3 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
288311-- | Print @,@.
289312comma :: R ()
290313comma = 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+78−69
@@ -7,17 +7,17 @@ module Ormolu.Printer.Comments
77 ( spitPrecedingComments,
88 spitFollowingComments,
99 spitRemainingComments,
10− spitCommentNow,
11− spitCommentPending,
1210 )
1311where
1412
1513import Control.Monad
14+import Data.Coerce (coerce)
15+import Data.Data (Data)
1616import qualified Data.List.NonEmpty as NE
17−import Data.Maybe (listToMaybe)
1817import qualified Data.Text as T
1918import Ormolu.Parser.CommentStream
2019import Ormolu.Printer.Internal
20+import Ormolu.Utils (isModule)
2121import SrcLoc
2222
2323----------------------------------------------------------------------------
@@ -25,91 +25,105 @@ import SrcLoc
2525
2626-- | Output all preceding comments for an element at given location.
2727spitPrecedingComments ::
28− -- | Span of the element to attach comments to
29− RealSrcSpan ->
28+ Data a =>
29+ -- | AST element to attach comments to
30+ RealLocated a ->
3031 R ()
3132spitPrecedingComments ref = do
32− gotSome <- handleCommentSeries (spitPrecedingComment ref)
33− when gotSome $ do
34− lastMark <- getSpanMark
35− -- Insert a blank line between the preceding comments and the thing
36− -- after them if there was a blank line in the input.
37− when (needsNewlineBefore ref lastMark) newline
33+ r <- getLastCommentSpan
34+ case r of
35+ Just (Just Pipe, _) ->
36+ -- We should not insert comments between pipe Haddock and the thing
37+ -- it's attached to.
38+ return ()
39+ _ -> do
40+ gotSome <- handleCommentSeries (spitPrecedingComment ref)
41+ when gotSome $ do
42+ -- Insert a blank line between the preceding comments and the thing
43+ -- after them if there was a blank line in the input.
44+ lastSpn <- fmap snd <$> getLastCommentSpan
45+ when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline
3846
3947-- | Output all comments following an element at given location.
4048spitFollowingComments ::
41− -- | Span of the element to attach comments to
42− RealSrcSpan ->
49+ Data a =>
50+ -- | AST element of attach comments to
51+ RealLocated a ->
4352 R ()
4453spitFollowingComments ref = do
45− trimSpanStream ref
54+ trimSpanStream (getRealSrcSpan ref)
4655 void $ handleCommentSeries (spitFollowingComment ref)
4756
4857-- | Output all remaining comments in the comment stream.
4958spitRemainingComments :: R ()
50−spitRemainingComments = do
51− -- Make sure we have a blank a line between the last definition and the
52− -- trailing comments.
53− newline
54− void $ handleCommentSeries spitRemainingComment
59+spitRemainingComments = void $ handleCommentSeries spitRemainingComment
5560
5661----------------------------------------------------------------------------
5762-- Single-comment functions
5863
5964-- | Output a single preceding comment for an element at given location.
6065spitPrecedingComment ::
61− -- | Span of the element to attach comments to
62− RealSrcSpan ->
66+ Data a =>
67+ -- | AST element to attach comments to
68+ RealLocated a ->
69+ -- | Location of last comment in the series
70+ Maybe RealSrcSpan ->
6371 -- | Are we done?
6472 R Bool
65−spitPrecedingComment ref = do
66− mlastMark <- getSpanMark
73+spitPrecedingComment (L ref a) mlastSpn = do
6774 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref
6875 withPoppedComment p $ \l comment -> do
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
76+ dirtyLine <-
77+ case mlastSpn of
78+ -- NOTE When the current line is dirty it means that something that
79+ -- can have comments attached to it is already on the line. To avoid
80+ -- problems with idempotence we cannot output the first comment
81+ -- immediately because it'll be attached to the previous element (on
82+ -- the same line) on the next run, so we play safe here and output
83+ -- an extra 'newline' in this case.
84+ Nothing -> isLineDirty -- only for very first preceding comment
85+ Just _ -> return False
86+ when (dirtyLine || needsNewlineBefore l mlastSpn) newline
7687 spitCommentNow l comment
77− if theSameLinePre l ref
88+ if theSameLinePre l ref && not (isModule a)
7889 then space
7990 else newline
8091
8192-- | Output a comment that follows element at given location immediately on
8293-- the same line, if there is any.
8394spitFollowingComment ::
95+ Data a =>
8496 -- | AST element to attach comments to
85− RealSrcSpan ->
97+ RealLocated a ->
98+ -- | Location of last comment in the series
99+ Maybe RealSrcSpan ->
86100 -- | Are we done?
87101 R Bool
88−spitFollowingComment ref = do
89− mlastMark <- getSpanMark
102+spitFollowingComment (L ref a) mlastSpn = do
90103 mnSpn <- nextEltSpan
91104 -- Get first enclosing span that is not equal to reference span, i.e. it's
92105 -- truly something enclosing the AST element.
93106 meSpn <- getEnclosingSpan (/= ref)
94− withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->
95− if theSameLinePost l ref
107+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->
108+ if theSameLinePost l ref && not (isModule a)
96109 then
97110 if isMultilineComment comment
98111 then space >> spitCommentNow l comment
99112 else spitCommentPending OnTheSameLine l comment
100113 else do
101− when (needsNewlineBefore l mlastMark) $
114+ when (needsNewlineBefore l mlastSpn) $
102115 registerPendingCommentLine OnNextLine ""
103116 spitCommentPending OnNextLine l comment
104117
105118-- | Output a single remaining comment from the comment stream.
106119spitRemainingComment ::
120+ -- | Location of last comment in the series
121+ Maybe RealSrcSpan ->
107122 -- | Are we done?
108123 R Bool
109−spitRemainingComment = do
110− mlastMark <- getSpanMark
124+spitRemainingComment mlastSpn =
111125 withPoppedComment (const True) $ \l comment -> do
112− when (needsNewlineBefore l mlastMark) newline
126+ when (needsNewlineBefore l mlastSpn) newline
113127 spitCommentNow l comment
114128 newline
115129
@@ -120,13 +134,13 @@ spitRemainingComment = do
120134handleCommentSeries ::
121135 -- | Given location of previous comment, output the next comment
122136 -- returning 'True' if we're done
123− R Bool ->
137+ (Maybe RealSrcSpan -> R Bool) ->
124138 -- | Whether we printed any comments
125139 R Bool
126140handleCommentSeries f = go False
127141 where
128142 go gotSome = do
129− done <- f
143+ done <- getLastCommentSpan >>= f . fmap snd
130144 if done
131145 then return gotSome
132146 else go True
@@ -152,14 +166,13 @@ needsNewlineBefore ::
152166 -- | Current comment span
153167 RealSrcSpan ->
154168 -- | Last printed comment span
155− Maybe SpanMark ->
169+ Maybe RealSrcSpan ->
156170 Bool
157−needsNewlineBefore _ (Just (HaddockSpan _ _)) = True
158−needsNewlineBefore l mlastMark =
159− case spanMarkSpan <$> mlastMark of
171+needsNewlineBefore l mlastSpn =
172+ case mlastSpn of
160173 Nothing -> False
161− Just lastMark ->
162− srcSpanStartLine l > srcSpanEndLine lastMark + 1
174+ Just lastSpn ->
175+ srcSpanStartLine l > srcSpanEndLine lastSpn + 1
163176
164177-- | Is the preceding comment and AST element are on the same line?
165178theSameLinePre ::
@@ -190,11 +203,11 @@ commentFollowsElt ::
190203 -- | Location of enclosing AST element
191204 Maybe RealSrcSpan ->
192205 -- | Location of last comment in the series
193− Maybe SpanMark ->
206+ Maybe RealSrcSpan ->
194207 -- | Comment to test
195208 RealLocated Comment ->
196209 Bool
197−commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =
210+commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =
198211 -- A comment follows a AST element if all 4 conditions are satisfied:
199212 goesAfter
200213 && logicallyFollows
@@ -207,8 +220,9 @@ commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =
207220 -- 2) The comment logically belongs to the element, four cases:
208221 logicallyFollows =
209222 theSameLinePost l ref -- a) it's on the same line
210− || continuation -- b) it's a continuation of a comment block
211− || lastInEnclosing -- c) it's the last element in the enclosing construct
223+ || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^
224+ || continuation -- c) it's a continuation of a comment block
225+ || lastInEnclosing -- d) it's the last element in the enclosing construct
212226
213227 -- 3) There is no other AST element between this element and the comment:
214228 noEltBetween =
@@ -230,20 +244,15 @@ commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =
230244 Nothing -> True
231245 Just espn ->
232246 let startColumn = srcLocCol . realSrcSpanStart
233− in startColumn espn > startColumn ref
234− || ( abs (startColumn espn - startColumn l)
235− >= abs (startColumn ref - startColumn l)
236− )
247+ in if startColumn espn > startColumn ref
248+ then True
249+ else
250+ abs (startColumn espn - startColumn l)
251+ >= abs (startColumn ref - startColumn l)
237252 continuation =
238− -- A comment is a continuation when it doesn't have non-whitespace
239− -- lexemes in front of it and goes right after the previous comment.
240− not (hasAtomsBefore comment)
241− && ( case mlastMark of
242− Just (HaddockSpan _ _) -> False
243− Just (CommentSpan spn) ->
244− srcSpanEndLine spn + 1 == srcSpanStartLine l
245− _ -> False
246− )
253+ case mlastSpn of
254+ Nothing -> False
255+ Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l
247256 lastInEnclosing =
248257 case meSpn of
249258 -- When there is no enclosing element, return false
@@ -265,9 +274,9 @@ spitCommentNow spn comment = do
265274 . sequence_
266275 . NE.intersperse newline
267276 . fmap (txt . T.pack)
268− . unComment
277+ . coerce
269278 $ comment
270− setSpanMark (CommentSpan spn)
279+ setLastCommentSpan Nothing spn
271280
272281-- | Output a 'Comment' at the end of correct line or after it depending on
273282-- 'CommentPosition'. Used for comments that may potentially follow on the
@@ -281,6 +290,6 @@ spitCommentPending position spn comment = do
281290 . sequence_
282291 . NE.toList
283292 . fmap (registerPendingCommentLine position . T.pack)
284− . unComment
293+ . coerce
285294 $ comment
286− setSpanMark (CommentSpan spn)
295+ setLastCommentSpan Nothing spn
src/Ormolu/Printer/Internal.hs+109−173
@@ -14,11 +14,10 @@ module Ormolu.Printer.Internal
1414
1515 -- * Internal functions
1616 txt,
17− interferingTxt,
1817 atom,
1918 space,
2019 newline,
21− useRecordDot,
20+ isLineDirty,
2221 inci,
2322 sitcc,
2423 Layout (..),
@@ -39,14 +38,9 @@ module Ormolu.Printer.Internal
3938 popComment,
4039 getEnclosingSpan,
4140 withEnclosingSpan,
42− thisLineSpans,
43−
44− -- * Stateful markers
45− SpanMark (..),
46− spanMarkSpan,
4741 HaddockStyle (..),
48− setSpanMark,
49− getSpanMark,
42+ setLastCommentSpan,
43+ getLastCommentSpan,
5044
5145 -- * Annotations
5246 getAnns,
@@ -79,44 +73,43 @@ newtype R a = R (ReaderT RC (State SC) a)
7973
8074-- | Reader context of 'R'. This should be used when we control rendering by
8175-- enclosing certain expressions with wrappers.
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− }
76+data RC
77+ = RC
78+ { -- | Indentation level, as the column index we need to start from after
79+ -- a newline if we break lines
80+ rcIndent :: !Int,
81+ -- | Current layout
82+ rcLayout :: Layout,
83+ -- | Spans of enclosing elements of AST
84+ rcEnclosingSpans :: [RealSrcSpan],
85+ -- | Collection of annotations
86+ rcAnns :: Anns,
87+ -- | If the last expression in the layout can use braces
88+ rcCanUseBraces :: Bool
89+ }
9790
9891-- | State context of 'R'.
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− }
92+data SC
93+ = SC
94+ { -- | Index of the next column to render
95+ scColumn :: !Int,
96+ -- | Rendered source code so far
97+ scBuilder :: Builder,
98+ -- | Span stream
99+ scSpanStream :: SpanStream,
100+ -- | Comment stream
101+ scCommentStream :: CommentStream,
102+ -- | Pending comment lines (in reverse order) to be inserted before next
103+ -- newline, 'Int' is the indentation level
104+ scPendingComments :: ![(CommentPosition, Int, Text)],
105+ -- | Whether the current line is “dirty”, that is, already contains
106+ -- atoms that can have comments attached to them
107+ scDirtyLine :: !Bool,
108+ -- | Whether to output a space before the next output
109+ scRequestedDelimiter :: !RequestedDelimiter,
110+ -- | Span of last output comment
111+ scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
112+ }
120113
121114-- | Make sure next output is delimited by one of the following.
122115data RequestedDelimiter
@@ -158,55 +151,32 @@ runR ::
158151 CommentStream ->
159152 -- | Annotations
160153 Anns ->
161− -- | Use Record Dot Syntax
162− Bool ->
163154 -- | Resulting rendition
164155 Text
165−runR (R m) sstream cstream anns recDot =
156+runR (R m) sstream cstream anns =
166157 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
167158 where
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− }
159+ rc = RC
160+ { rcIndent = 0,
161+ rcLayout = MultiLine,
162+ rcEnclosingSpans = [],
163+ rcAnns = anns,
164+ rcCanUseBraces = False
165+ }
166+ sc = SC
167+ { scColumn = 0,
168+ scBuilder = mempty,
169+ scSpanStream = sstream,
170+ scCommentStream = cstream,
171+ scPendingComments = [],
172+ scDirtyLine = False,
173+ scRequestedDelimiter = VeryBeginning,
174+ scLastCommentSpan = Nothing
175+ }
189176
190177----------------------------------------------------------------------------
191178-- Internal functions
192179
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−
210180-- | Output a fixed 'Text' fragment. The argument may not contain any line
211181-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
212182-- keywords and pipes @|@ in functional dependencies.
@@ -218,15 +188,7 @@ txt ::
218188 -- | 'Text' to output
219189 Text ->
220190 R ()
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
191+txt = spit False False
230192
231193-- | Output 'Outputable' fragment of AST. This can be used to output numeric
232194-- literals and similar. Everything that doesn't have inner structure but
@@ -235,61 +197,48 @@ atom ::
235197 Outputable a =>
236198 a ->
237199 R ()
238−atom = spit Atom . T.pack . showOutputable
200+atom = spit True False . T.pack . showOutputable
239201
240202-- | Low-level non-public helper to define 'txt' and 'atom'.
241203spit ::
242− -- | Type of the thing to spit
243− SpitType ->
204+ -- | Should we mark the line as dirty?
205+ Bool ->
206+ -- | Used during outputting of pending comments?
207+ Bool ->
244208 -- | 'Text' to output
245209 Text ->
246210 R ()
247−spit _ "" = return ()
248−spit stype text = do
211+spit dirty printingComments txt' = do
249212 requestedDel <- R (gets scRequestedDelimiter)
250− pendingComments <- R (gets scPendingComments)
251− when (stype == InterferingText && not (null pendingComments)) newline
252213 case requestedDel of
253214 RequestedNewline -> do
254215 R . modify $ \sc ->
255216 sc
256217 { scRequestedDelimiter = RequestedNothing
257218 }
258− case stype of
259− CommentPart -> newlineRaw
260− _ -> newline
219+ if printingComments
220+ then newlineRaw
221+ else newline
261222 _ -> return ()
262223 R $ do
263224 i <- asks rcIndent
264225 c <- gets scColumn
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)
226+ let spaces =
227+ if c < i
228+ then T.replicate (i - c) " "
229+ else bool mempty " " (requestedDel == RequestedSpace)
230+ indentedTxt = spaces <> txt'
272231 modify $ \sc ->
273232 sc
274233 { scBuilder = scBuilder sc <> fromText indentedTxt,
275234 scColumn = scColumn sc + T.length indentedTxt,
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,
235+ scDirtyLine = scDirtyLine sc || dirty,
287236 scRequestedDelimiter = RequestedNothing,
288− scSpanMark =
289− -- If there are pending comments, do not reset last comment
237+ scLastCommentSpan =
238+ -- NOTE If there are pending comments, do not reset last comment
290239 -- location.
291− if (stype == CommentPart) || (not . null . scPendingComments) sc
292− then scSpanMark sc
240+ if printingComments || (not . null . scPendingComments) sc
241+ then scLastCommentSpan sc
293242 else Nothing
294243 }
295244
@@ -320,22 +269,21 @@ space = R . modify $ \sc ->
320269-- hard to output more than one blank newline in a row.
321270newline :: R ()
322271newline = do
323− indent <- R (gets scIndent)
324272 cs <- reverse <$> R (gets scPendingComments)
325273 case cs of
326274 [] -> newlineRaw
327− ((position, _) : _) -> do
275+ ((position, _, _) : _) -> do
328276 case position of
329277 OnTheSameLine -> space
330278 OnNextLine -> newlineRaw
331− R . forM_ cs $ \(_, text) ->
279+ R . forM_ cs $ \(_, indent, txt') ->
332280 let modRC rc =
333281 rc
334282 { rcIndent = indent
335283 }
336284 R m = do
337− unless (T.null text) $
338− spit CommentPart text
285+ unless (T.null txt') $
286+ spit False True txt'
339287 newlineRaw
340288 in local modRC m
341289 R . modify $ \sc ->
@@ -356,8 +304,7 @@ newlineRaw = R . modify $ \sc ->
356304 VeryBeginning -> builderSoFar
357305 _ -> builderSoFar <> "\n",
358306 scColumn = 0,
359− scIndent = 0,
360− scThisLineSpans = [],
307+ scDirtyLine = False,
361308 scRequestedDelimiter = case scRequestedDelimiter sc of
362309 AfterNewline -> RequestedNewline
363310 RequestedNewline -> RequestedNewline
@@ -365,9 +312,10 @@ newlineRaw = R . modify $ \sc ->
365312 _ -> AfterNewline
366313 }
367314
368−-- | Return 'True' if we should print record dot syntax.
369−useRecordDot :: R Bool
370−useRecordDot = R (asks rcUseRecDot)
315+-- | Check if the current line is “dirty”, that is, there is something on it
316+-- that can have comments attached to it.
317+isLineDirty :: R Bool
318+isLineDirty = R (gets scDirtyLine)
371319
372320-- | Increase indentation level by one indentation step for the inner
373321-- computation. 'inci' should be used when a part of code must be more
@@ -384,7 +332,8 @@ inci (R m) = R (local modRC m)
384332
385333-- | Set indentation level for the inner computation equal to current
386334-- column. This makes sure that the entire inner block is uniformly
387−-- \"shifted\" to the right.
335+-- \"shifted\" to the right. Only works (and makes sense) when enclosing
336+-- layout is multi-line.
388337sitcc :: R () -> R ()
389338sitcc (R m) = do
390339 requestedDel <- R (gets scRequestedDelimiter)
@@ -392,9 +341,16 @@ sitcc (R m) = do
392341 c <- R (gets scColumn)
393342 let modRC rc =
394343 rc
395− { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))
344+ { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
396345 }
397− R (local modRC m)
346+ vlayout (R m) . R $ do
347+ modify $ \sc ->
348+ sc
349+ { scRequestedDelimiter = case requestedDel of
350+ RequestedSpace -> RequestedNothing
351+ other -> other
352+ }
353+ local modRC m
398354
399355-- | Set 'Layout' for internal computation.
400356enterLayout :: Layout -> R () -> R ()
@@ -435,10 +391,11 @@ registerPendingCommentLine ::
435391 -- | 'Text' to output
436392 Text ->
437393 R ()
438−registerPendingCommentLine position text = R $ do
394+registerPendingCommentLine position txt' = R $ do
395+ i <- asks rcIndent
439396 modify $ \sc ->
440397 sc
441− { scPendingComments = (position, text) : scPendingComments sc
398+ { scPendingComments = (position, i, txt') : scPendingComments sc
442399 }
443400
444401-- | Drop elements that begin before or at the same place as given
@@ -497,29 +454,6 @@ withEnclosingSpan spn (R m) = R (local modRC m)
497454 { rcEnclosingSpans = spn : rcEnclosingSpans rc
498455 }
499456
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−
523457-- | Haddock string style.
524458data HaddockStyle
525459 = -- | @-- |@
@@ -532,18 +466,20 @@ data HaddockStyle
532466 Named String
533467
534468-- | Set span of last output comment.
535−setSpanMark ::
536− -- | Span mark to set
537− SpanMark ->
469+setLastCommentSpan ::
470+ -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
471+ Maybe HaddockStyle ->
472+ -- | Location of last printed comment
473+ RealSrcSpan ->
538474 R ()
539−setSpanMark spnMark = R . modify $ \sc ->
475+setLastCommentSpan mhStyle spn = R . modify $ \sc ->
540476 sc
541− { scSpanMark = Just spnMark
477+ { scLastCommentSpan = Just (mhStyle, spn)
542478 }
543479
544480-- | Get span of last output comment.
545−getSpanMark :: R (Maybe SpanMark)
546−getSpanMark = R (gets scSpanMark)
481+getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
482+getLastCommentSpan = R (gets scLastCommentSpan)
547483
548484----------------------------------------------------------------------------
549485-- Annotations
@@ -567,7 +503,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
567503
568504-- | Return 'True' if we can use braces in this context.
569505canUseBraces :: R Bool
570−canUseBraces = R (asks rcCanUseBraces)
506+canUseBraces = R $ asks rcCanUseBraces
571507
572508----------------------------------------------------------------------------
573509-- Constants
src/Ormolu/Printer/Meat/Common.hs+18−20
@@ -17,12 +17,14 @@ where
1717
1818import Control.Monad
1919import Data.List (isPrefixOf)
20+import Data.Maybe (isJust)
2021import qualified Data.Text as T
2122import GHC hiding (GhcPs, IE)
2223import Name (nameStableString)
2324import OccName (OccName (..))
2425import Ormolu.Printer.Combinators
2526import Ormolu.Utils
27+import RdrName (RdrName (..))
2628
2729-- | Data and type family style.
2830data FamilyStyle
@@ -74,10 +76,10 @@ p_rdrName l@(L spn _) = located l $ \x -> do
7476 Qual mname occName ->
7577 p_qualName mname occName
7678 Orig _ occName ->
77− -- This is used when GHC generates code that will be fed into
78− -- the renamer (e.g. from deriving clauses), but where we want
79− -- to say that something comes from given module which is not
80− -- specified in the source code, e.g. @Prelude.map@.
79+ -- NOTE This is used when GHC generates code that will be fed
80+ -- into the renamer (e.g. from deriving clauses), but where we
81+ -- want to say that something comes from given module which is
82+ -- not specified in the source code, e.g. @Prelude.map@.
8183 --
8284 -- My current understanding is that the provided module name
8385 -- serves no purpose for us and can be safely ignored.
@@ -97,9 +99,9 @@ doesNotNeedExtraParens :: RdrName -> Bool
9799doesNotNeedExtraParens = \case
98100 Exact name ->
99101 let s = nameStableString name
100− in -- I'm not sure this "stable string" is stable enough, but it looks
101− -- like this is the most robust way to tell if we're looking at
102− -- exactly this piece of built-in syntax.
102+ in -- NOTE I'm not sure this "stable string" is stable enough, but it looks
103+ -- like this is the most robust way to tell if we're looking at exactly
104+ -- this piece of built-in syntax.
103105 ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s)
104106 || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s)
105107 _ -> False
@@ -114,14 +116,14 @@ p_qualName mname occName = do
114116p_infixDefHelper ::
115117 -- | Whether to format in infix style
116118 Bool ->
117− -- | Whether to bump indentation for arguments
118− Bool ->
119+ -- | Indentation-bumping wrapper
120+ (R () -> R ()) ->
119121 -- | How to print the operator\/name
120122 R () ->
121123 -- | How to print the arguments
122124 [R ()] ->
123125 R ()
124−p_infixDefHelper isInfix indentArgs name args =
126+p_infixDefHelper isInfix inci' name args =
125127 case (isInfix, args) of
126128 (True, p0 : p1 : ps) -> do
127129 let parens' =
@@ -131,18 +133,18 @@ p_infixDefHelper isInfix indentArgs name args =
131133 parens' $ do
132134 p0
133135 breakpoint
134− inci . sitcc $ do
136+ inci $ sitcc $ do
135137 name
136138 space
137139 p1
138− unless (null ps) . inciIf indentArgs $ do
140+ unless (null ps) . inci' $ do
139141 breakpoint
140142 sitcc (sep breakpoint sitcc ps)
141143 (_, ps) -> do
142144 name
143145 unless (null ps) $ do
144146 breakpoint
145− inciIf indentArgs $ sitcc (sep breakpoint sitcc args)
147+ inci' $ sitcc (sep breakpoint sitcc args)
146148
147149-- | Print a Haddock.
148150p_hsDocString ::
@@ -154,11 +156,7 @@ p_hsDocString ::
154156 LHsDocString ->
155157 R ()
156158p_hsDocString hstyle needsNewline (L l str) = do
157− let isCommentSpan = \case
158− HaddockSpan _ _ -> True
159− CommentSpan _ -> True
160− _ -> False
161− goesAfterComment <- maybe False isCommentSpan <$> getSpanMark
159+ goesAfterComment <- isJust <$> getLastCommentSpan
162160 -- Make sure the Haddock is separated by a newline from other comments.
163161 when goesAfterComment newline
164162 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do
@@ -177,8 +175,8 @@ p_hsDocString hstyle needsNewline (L l str) = do
177175 -- It's often the case that the comment itself doesn't have a span
178176 -- attached to it and instead its location can be obtained from
179177 -- nearest enclosing span.
180− getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)
181− RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)
178+ getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))
179+ RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
182180
183181-- | Print anchor of named doc section.
184182p_hsDocName :: String -> R ()
src/Ormolu/Printer/Meat/Declaration.hs+110−175
@@ -7,12 +7,12 @@
77-- | Rendering of declarations.
88module Ormolu.Printer.Meat.Declaration
99 ( p_hsDecls,
10− p_hsDeclsRespectGrouping,
10+ hasSeparatedDecls,
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,57 +34,25 @@ import Ormolu.Printer.Meat.Declaration.Value
3434import Ormolu.Printer.Meat.Declaration.Warning
3535import Ormolu.Printer.Meat.Type
3636import Ormolu.Utils
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)
37+import RdrName (rdrNameOcc)
4438
4539p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
46−p_hsDecls = p_hsDecls' Disregard
47−
48−-- | Like 'p_hsDecls' but respects user choices regarding grouping. If the
49−-- user omits newlines between declarations, we also omit them in most
50−-- cases, except when said declarations have associated Haddocks.
51−--
52−-- Does some normalization (compress subsequent newlines into a single one)
53−p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
54−p_hsDeclsRespectGrouping = p_hsDecls' Respect
55−
56−p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
57−p_hsDecls' grouping style decls =
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)
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
6448 where
65− renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
66− renderGroupWithPrev prev curr =
67− -- We can omit a blank line when the user didn't add one, but we must
68− -- ensure we always add blank lines around documented declarations
69− case grouping of
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
49+ renderGroup = fmap (located' $ dontUseBraces . p_hsDecl style)
50+ separateGroup (x :| xs) = (breakpoint' >> x) :| xs
8651
8752-- | 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.
8856groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]
8957groupDecls [] = []
9058groupDecls (l@(L _ DocNext) : xs) =
@@ -93,40 +61,44 @@ groupDecls (l@(L _ DocNext) : xs) =
9361 case groupDecls xs of
9462 [] -> [l :| []]
9563 (x : xs') -> (l <| x) : xs'
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)
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)
10376
10477p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()
10578p_hsDecl style = \case
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 ->
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 ->
11891 case docDecl of
11992 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)
12093 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)
12194 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)
12295 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)
123− RoleAnnotD NoExtField x -> p_roleAnnot x
124− KindSigD NoExtField s -> p_standaloneKindSig s
125− XHsDecl x -> noExtCon x
96+ RoleAnnotD NoExt x -> p_roleAnnot x
97+ XHsDecl _ -> notImplemented "XHsDecl"
12698
12799p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()
128100p_tyClDecl style = \case
129− FamDecl NoExtField x -> p_famDecl style x
101+ FamDecl NoExt x -> p_famDecl style x
130102 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs
131103 DataDecl {..} ->
132104 p_dataDecl
@@ -147,65 +119,39 @@ p_tyClDecl style = \case
147119 tcdATs
148120 tcdATDefs
149121 tcdDocs
150− XTyClDecl x -> noExtCon x
122+ XTyClDecl {} -> notImplemented "XTyClDecl"
151123
152124p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()
153125p_instDecl style = \case
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
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"
158130
159131p_derivDecl :: DerivDecl GhcPs -> R ()
160132p_derivDecl = \case
161− d@DerivDecl {} -> p_standaloneDerivDecl d
162− XDerivDecl x -> noExtCon x
133+ d@DerivDecl {..} -> p_standaloneDerivDecl d
134+ XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
163135
164136-- | Determine if these declarations should be grouped together.
165137groupedDecls ::
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 ->
138+ HsDecl GhcPs ->
139+ HsDecl GhcPs ->
202140 Bool
203−declSeries (L _ x) (L _ y) =
204− case (x, y) of
205− ( SigD NoExtField (TypeSig NoExtField _ _),
206− SigD NoExtField (TypeSig NoExtField _ _)
207− ) -> True
208− _ -> False
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
209155
210156intersects :: Ord a => [a] -> [a] -> Bool
211157intersects a b = go (sort a) (sort b)
@@ -218,6 +164,13 @@ intersects a b = go (sort a) (sort b)
218164 | x > y = go (x : xs) ys
219165 | otherwise = True
220166
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+
221174isPragma ::
222175 HsDecl GhcPs ->
223176 Maybe [RdrName]
@@ -230,11 +183,6 @@ isPragma = \case
230183 WarningPragma n -> Just n
231184 _ -> Nothing
232185
233−-- Declarations that do not refer to names
234−
235−pattern Splice :: HsDecl GhcPs
236−pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)
237−
238186-- Declarations referring to a single name
239187
240188pattern
@@ -244,84 +192,71 @@ pattern
244192 AnnTypePragma,
245193 AnnValuePragma,
246194 Pattern,
247− DataDeclaration,
248− ClassDeclaration,
249− KindSignature,
250− FamilyDeclaration ::
195+ DataDeclaration ::
251196 RdrName -> HsDecl GhcPs
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) _ _ _ _))
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) _ _ _)
262204
263205-- Declarations which can refer to multiple names
264206
265207pattern
266208 TypeSignature,
267− DefaultSignature,
268209 FunctionBody,
269210 PatternSignature,
270211 WarningPragma ::
271212 [RdrName] -> HsDecl GhcPs
272213pattern TypeSignature n <- (sigRdrNames -> Just n)
273−pattern DefaultSignature n <- (defSigRdrNames -> Just n)
274214pattern FunctionBody n <- (funRdrNames -> Just n)
275215pattern PatternSignature n <- (patSigRdrNames -> Just n)
276216pattern WarningPragma n <- (warnSigRdrNames -> Just n)
277217
278218pattern DocNext, DocPrev :: HsDecl GhcPs
279−pattern DocNext <- (DocD NoExtField (DocCommentNext _))
280−pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))
219+pattern DocNext <- (DocD NoExt (DocCommentNext _))
220+pattern DocPrev <- (DocD NoExt (DocCommentPrev _))
281221
282222sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
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
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
286226sigRdrNames _ = Nothing
287227
288−defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
289−defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns
290−defSigRdrNames _ = Nothing
291−
292228funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
293−funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]
294−funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n
229+funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]
230+funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n
295231funRdrNames _ = Nothing
296232
297233patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
298−patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns
234+patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns
299235patSigRdrNames _ = Nothing
300236
301237warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
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
238+warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case
239+ L _ (Warning NoExt ns _) -> map unLoc ns
240+ L _ (XWarnDecl NoExt) -> []
306241warnSigRdrNames _ = Nothing
307242
308243patBindNames :: Pat GhcPs -> [RdrName]
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]
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]
324259patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)
325−patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer
326−patBindNames (CoPat NoExtField _ p _) = patBindNames p
327−patBindNames (XPat x) = noExtCon x
260+patBindNames (ConPatOut _ _ _ _ _ _ _) = notImplemented "ConPatOut" -- created by renamer
261+patBindNames (CoPat NoExt _ p _) = patBindNames p
262+patBindNames (XPat p) = patBindNames (unLoc p)
src/Ormolu/Printer/Meat/Declaration.hs-boot+3−2
@@ -1,6 +1,6 @@
11module Ormolu.Printer.Meat.Declaration
22 ( p_hsDecls,
3− p_hsDeclsRespectGrouping,
3+ hasSeparatedDecls,
44 )
55where
66
@@ -9,4 +9,5 @@ import Ormolu.Printer.Combinators
99import Ormolu.Printer.Meat.Common
1010
1111p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12−p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
12+
13+hasSeparatedDecls :: [LHsDecl GhcPs] -> Bool
src/Ormolu/Printer/Meat/Declaration/Annotation.hs+3−2
@@ -10,14 +10,15 @@ import GHC
1010import Ormolu.Printer.Combinators
1111import Ormolu.Printer.Meat.Common
1212import Ormolu.Printer.Meat.Declaration.Value
13+import Ormolu.Utils
1314
1415p_annDecl :: AnnDecl GhcPs -> R ()
1516p_annDecl = \case
16− HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do
17+ HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do
1718 p_annProv annProv
1819 breakpoint
1920 located expr p_hsExpr
20− XAnnDecl x -> noExtCon x
21+ XAnnDecl {} -> notImplemented "XAnnDecl"
2122
2223p_annProv :: AnnProvenance (IdP GhcPs) -> R ()
2324p_annProv = \case
src/Ormolu/Printer/Meat/Declaration/Class.hs+38−26
@@ -12,12 +12,15 @@ import Class
1212import Control.Arrow
1313import Control.Monad
1414import Data.Foldable
15−import Data.List (sortOn)
15+import Data.List (sortBy)
16+import Data.Ord (comparing)
1617import GHC
1718import Ormolu.Printer.Combinators
1819import Ormolu.Printer.Meat.Common
1920import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
2021import Ormolu.Printer.Meat.Type
22+import Ormolu.Utils
23+import RdrName (RdrName (..))
2124
2225p_classDecl ::
2326 LHsContext GhcPs ->
@@ -28,47 +31,49 @@ p_classDecl ::
2831 [LSig GhcPs] ->
2932 LHsBinds GhcPs ->
3033 [LFamilyDecl GhcPs] ->
31− [LTyFamDefltDecl GhcPs] ->
34+ [LTyFamDefltEqn GhcPs] ->
3235 [LDocDecl] ->
3336 R ()
34−p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do
35− let variableSpans = getLoc <$> hsq_explicit
37+p_classDecl ctx name tvars fixity fdeps csigs cdefs cats catdefs cdocs = do
38+ let HsQTvs {..} = tvars
39+ variableSpans = getLoc <$> hsq_explicit
3640 signatureSpans = getLoc name : variableSpans
3741 dependencySpans = getLoc <$> fdeps
3842 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)
5343 txt "class"
5444 switchLayout combinedSpans $ do
5545 breakpoint
5646 inci $ do
5747 p_classContext ctx
58− switchLayout signatureSpans $
48+ switchLayout signatureSpans $ do
5949 p_infixDefHelper
6050 (isInfix fixity)
61− True
51+ inci
6252 (p_rdrName name)
6353 (located' p_hsTyVarBndr <$> hsq_explicit)
6454 inci (p_classFundeps fdeps)
65− unless (null allDecls) $ do
66− breakpoint
67− txt "where"
55+ -- NOTE GHC's AST does not necessarily store each kind of element in
56+ -- source location order. This happens because different declarations are
57+ -- stored in different lists. Consequently, to get all the declarations in
58+ -- proper order, they need to be manually sorted.
59+ let sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs
60+ vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs
61+ tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats
62+ docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs
63+ tyFamDefs =
64+ ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)
65+ )
66+ <$> catdefs
67+ allDecls =
68+ snd <$> sortBy (comparing fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs)
6869 unless (null allDecls) $ do
70+ space
71+ txt "where"
6972 breakpoint -- Ensure whitespace is added after where clause.
70− inci (p_hsDeclsRespectGrouping Associated allDecls)
71−p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c
73+ -- Add newline before first declaration if the body contains separate
74+ -- declarations.
75+ when (hasSeparatedDecls allDecls) breakpoint'
76+ inci (p_hsDecls Associated allDecls)
7277
7378p_classContext :: LHsContext GhcPs -> R ()
7479p_classContext ctx = unless (null (unLoc ctx)) $ do
@@ -82,7 +87,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do
8287 breakpoint
8388 txt "|"
8489 space
85− inci $ sep commaDel (sitcc . located' p_funDep) fdeps
90+ sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps
8691
8792p_funDep :: FunDep (Located RdrName) -> R ()
8893p_funDep (before, after) = do
@@ -95,6 +100,13 @@ p_funDep (before, after) = do
95100----------------------------------------------------------------------------
96101-- Helpers
97102
103+defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs
104+defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}
105+ where
106+ eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}
107+ tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}
108+defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"
109+
98110isInfix :: LexicalFixity -> Bool
99111isInfix = \case
100112 Infix -> True
src/Ormolu/Printer/Meat/Declaration/Data.hs+47−74
@@ -9,12 +9,15 @@ module Ormolu.Printer.Meat.Declaration.Data
99where
1010
1111import Control.Monad
12−import Data.Maybe (isJust, maybeToList)
12+import Data.Maybe (isJust)
13+import Data.Maybe (maybeToList)
1314import GHC
1415import Ormolu.Printer.Combinators
1516import Ormolu.Printer.Meat.Common
1617import Ormolu.Printer.Meat.Type
1718import Ormolu.Utils
19+import RdrName (RdrName (..))
20+import SrcLoc (Located)
1821
1922p_dataDecl ::
2023 -- | Whether to format as data family
@@ -35,13 +38,12 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
3538 txt $ case style of
3639 Associated -> mempty
3740 Free -> " instance"
38− let constructorSpans = getLoc name : fmap getLoc tpats
39− switchLayout constructorSpans $ do
41+ switchLayout (getLoc name : fmap getLoc tpats) $ do
4042 breakpoint
4143 inci $
4244 p_infixDefHelper
4345 (isInfix fixity)
44− True
46+ inci
4547 (p_rdrName name)
4648 (located' p_hsType <$> tpats)
4749 case dd_kindSig of
@@ -54,42 +56,29 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
5456 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons
5557 unless (null dd_cons) $
5658 if gadt
57− then inci $ do
58− switchLayout constructorSpans $ do
59− breakpoint
60− txt "where"
61− breakpoint
62− sepSemi (located' (p_conDecl False)) dd_cons
63− else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do
64− let singleConstRec = isSingleConstRec dd_cons
65− if singleConstRec
66− then space
67− else
68− if hasHaddocks dd_cons
69− then newline
70− else breakpoint
71− equals
59+ then do
7260 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
61+ txt "where"
62+ breakpoint
63+ inci $ sepSemi (located' p_conDecl) dd_cons
64+ else switchLayout (getLoc name : (getLoc <$> dd_cons))
65+ $ inci
66+ $ do
67+ breakpoint
68+ txt "="
69+ space
70+ let s =
71+ vlayout
72+ (space >> txt "|" >> space)
73+ (newline >> txt "|" >> space)
74+ sep s (sitcc . located' p_conDecl) dd_cons
8375 unless (null $ unLoc dd_derivs) breakpoint
84− inci . located dd_derivs $ \xs ->
76+ inci . located dd_derivs $ \xs -> do
8577 sep newline (located' p_hsDerivingClause) xs
86−p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x
78+p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"
8779
88−p_conDecl ::
89− Bool ->
90− ConDecl GhcPs ->
91− R ()
92−p_conDecl singleConstRec = \case
80+p_conDecl :: ConDecl GhcPs -> R ()
81+p_conDecl = \case
9382 ConDeclGADT {..} -> do
9483 mapM_ (p_hsDocString Pipe True) con_doc
9584 let conDeclSpn =
@@ -104,19 +93,19 @@ p_conDecl singleConstRec = \case
10493 (c : cs) -> do
10594 p_rdrName c
10695 unless (null cs) . inci $ do
107− commaDel
108− sep commaDel p_rdrName cs
96+ comma
97+ breakpoint
98+ sitcc $ sep (comma >> breakpoint) p_rdrName cs
99+ space
109100 inci $ do
110− space
111101 txt "::"
112102 let interArgBreak =
113103 if hasDocStrings (unLoc con_res_ty)
114104 then newline
115105 else breakpoint
116106 interArgBreak
117− when (unLoc con_forall) $ do
118− p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)
119− interArgBreak
107+ p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)
108+ unless (null $ hsq_explicit con_qvars) interArgBreak
120109 forM_ con_mb_cxt p_lhsContext
121110 case con_args of
122111 PrefixCon xs -> do
@@ -135,27 +124,24 @@ p_conDecl singleConstRec = \case
135124 p_hsType (unLoc con_res_ty)
136125 ConDeclH98 {..} -> do
137126 mapM_ (p_hsDocString Pipe True) con_doc
138− let conDeclWithContextSpn =
139− [getLoc con_forall]
127+ let conDeclSpn =
128+ [getLoc con_name]
140129 <> fmap getLoc con_ex_tvs
141130 <> maybeToList (fmap getLoc con_mb_cxt)
142− <> conDeclSpn
143− conDeclSpn =
144− getLoc con_name : conArgsSpans con_args
145− switchLayout conDeclWithContextSpn $ do
146− when (unLoc con_forall) $ do
147− p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs
148− breakpoint
131+ <> conArgsSpans con_args
132+ switchLayout conDeclSpn $ do
133+ p_forallBndrs p_hsTyVarBndr con_ex_tvs
134+ unless (null con_ex_tvs) breakpoint
149135 forM_ con_mb_cxt p_lhsContext
150− switchLayout conDeclSpn $ case con_args of
136+ case con_args of
151137 PrefixCon xs -> do
152138 p_rdrName con_name
153139 unless (null xs) breakpoint
154− inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs
140+ inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs
155141 RecCon l -> do
156142 p_rdrName con_name
157143 breakpoint
158− inciIf (not singleConstRec) (located l p_conDeclFields)
144+ inci $ located l p_conDeclFields
159145 InfixCon x y -> do
160146 located x p_hsType
161147 breakpoint
@@ -163,7 +149,7 @@ p_conDecl singleConstRec = \case
163149 p_rdrName con_name
164150 space
165151 located y p_hsType
166− XConDecl x -> noExtCon x
152+ XConDecl NoExt -> notImplemented "XConDecl"
167153
168154conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]
169155conArgsSpans = \case
@@ -177,7 +163,7 @@ conArgsSpans = \case
177163conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
178164conTyVarsSpans = \case
179165 HsQTvs {..} -> getLoc <$> hsq_explicit
180− XLHsQTyVars x -> noExtCon x
166+ XLHsQTyVars NoExt -> []
181167
182168p_lhsContext ::
183169 LHsContext GhcPs ->
@@ -204,9 +190,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
204190 let derivingWhat = located deriv_clause_tys $ \case
205191 [] -> txt "()"
206192 xs ->
207− parens N $
193+ parens N . sitcc $
208194 sep
209− commaDel
195+ (comma >> breakpoint)
210196 (sitcc . located' p_hsType . hsib_body)
211197 xs
212198 space
@@ -235,9 +221,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
235221 txt "via"
236222 space
237223 located hsib_body p_hsType
238− ViaStrategy (XHsImplicitBndrs x) ->
239− noExtCon x
240−p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
224+ ViaStrategy (XHsImplicitBndrs NoExt) ->
225+ notImplemented "XHsImplicitBndrs"
226+p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
241227
242228----------------------------------------------------------------------------
243229-- Helpers
@@ -246,16 +232,3 @@ isInfix :: LexicalFixity -> Bool
246232isInfix = \case
247233 Infix -> True
248234 Prefix -> False
249−
250−isSingleConstRec :: [LConDecl GhcPs] -> Bool
251−isSingleConstRec [(L _ ConDeclH98 {..})] =
252− case con_args of
253− RecCon _ -> True
254− _ -> False
255−isSingleConstRec _ = False
256−
257−hasHaddocks :: [LConDecl GhcPs] -> Bool
258−hasHaddocks = any (f . unLoc)
259− where
260− f ConDeclH98 {..} = isJust con_doc
261− f _ = False
src/Ormolu/Printer/Meat/Declaration/Default.hs+5−4
@@ -9,12 +9,13 @@ where
99import GHC
1010import Ormolu.Printer.Combinators
1111import Ormolu.Printer.Meat.Type
12+import Ormolu.Utils
1213
1314p_defaultDecl :: DefaultDecl GhcPs -> R ()
1415p_defaultDecl = \case
15− DefaultDecl NoExtField ts -> do
16+ DefaultDecl NoExt ts -> do
1617 txt "default"
1718 breakpoint
18− inci . parens N $
19− sep commaDel (sitcc . located' p_hsType) ts
20− XDefaultDecl x -> noExtCon x
19+ inci . parens N . sitcc $
20+ sep (comma >> breakpoint) (sitcc . located' p_hsType) ts
21+ XDefaultDecl {} -> notImplemented "XDefaultDecl"
src/Ormolu/Printer/Meat/Declaration/Foreign.hs+3−2
@@ -15,6 +15,7 @@ import GHC
1515import Ormolu.Printer.Combinators
1616import Ormolu.Printer.Meat.Common
1717import Ormolu.Printer.Meat.Declaration.Signature
18+import Ormolu.Utils
1819
1920p_foreignDecl :: ForeignDecl GhcPs -> R ()
2021p_foreignDecl = \case
@@ -24,7 +25,7 @@ p_foreignDecl = \case
2425 fd@ForeignExport {fd_fe} -> do
2526 p_foreignExport fd_fe
2627 p_foreignTypeSig fd
27− XForeignDecl x -> noExtCon x
28+ XForeignDecl {} -> notImplemented "XForeignDecl"
2829
2930-- | Printer for the last part of an import\/export, which is function name
3031-- and type signature.
@@ -38,7 +39,7 @@ p_foreignTypeSig fd = do
3839 ]
3940 $ do
4041 p_rdrName (fd_name fd)
41− p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
42+ p_typeAscription (HsWC NoExt (fd_sig_ty fd))
4243
4344-- | Printer for 'ForeignImport'.
4445--
src/Ormolu/Printer/Meat/Declaration/Instance.hs+27−21
@@ -15,7 +15,8 @@ import BasicTypes
1515import Control.Arrow
1616import Control.Monad
1717import Data.Foldable
18−import Data.List (sortOn)
18+import Data.List (sortBy)
19+import Data.Ord (comparing)
1920import GHC
2021import Ormolu.Printer.Combinators
2122import Ormolu.Printer.Meat.Common
@@ -32,11 +33,13 @@ p_standaloneDerivDecl DerivDecl {..} = do
3233 txt "instance"
3334 breakpoint
3435 match_overlap_mode deriv_overlap_mode breakpoint
35− inciIf toIndent typesAfterInstance
36+ if toIndent
37+ then inci typesAfterInstance
38+ else typesAfterInstance
3639 txt "deriving"
3740 space
3841 case deriv_strategy of
39− Nothing ->
42+ Nothing -> do
4043 instTypes False
4144 Just (L _ a) -> case a of
4245 StockStrategy -> do
@@ -54,8 +57,8 @@ p_standaloneDerivDecl DerivDecl {..} = do
5457 inci (located hsib_body p_hsType)
5558 breakpoint
5659 instTypes True
57− ViaStrategy (XHsImplicitBndrs x) ->
58− noExtCon x
60+ ViaStrategy (XHsImplicitBndrs NoExt) ->
61+ notImplemented "XHsImplicitBndrs"
5962p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"
6063
6164p_clsInstDecl :: ClsInstDecl GhcPs -> R ()
@@ -68,18 +71,19 @@ p_clsInstDecl = \case
6871 -- location order. This happens because different declarations are stored in
6972 -- different lists. Consequently, to get all the declarations in proper
7073 -- order, they need to be manually sorted.
71− let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs
72− vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds
74+ let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs
75+ vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds
7376 tyFamInsts =
74− ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)
77+ ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)
7578 )
7679 <$> cid_tyfam_insts
7780 dataFamInsts =
78− ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)
81+ ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)
7982 )
8083 <$> cid_datafam_insts
8184 allDecls =
82− snd <$> sortOn fst (sigs <> vals <> tyFamInsts <> dataFamInsts)
85+ snd
86+ <$> sortBy (comparing fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)
8387 located hsib_body $ \x -> do
8488 breakpoint
8589 inci $ do
@@ -88,12 +92,16 @@ p_clsInstDecl = \case
8892 unless (null allDecls) $ do
8993 breakpoint
9094 txt "where"
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
95+ unless (null allDecls) $ do
96+ inci $ do
97+ -- Ensure whitespace is added after where clause.
98+ breakpoint
99+ -- Add newline before first declaration if the body contains separate
100+ -- declarations
101+ when (hasSeparatedDecls allDecls) breakpoint'
102+ dontUseBraces $ p_hsDecls Associated allDecls
103+ XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"
104+ XClsInstDecl NoExt -> notImplemented "XClsInstDecl"
97105
98106p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()
99107p_tyFamInstDecl style = \case
@@ -106,12 +114,10 @@ p_tyFamInstDecl style = \case
106114
107115p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R ()
108116p_dataFamInstDecl style = \case
109− DataFamInstDecl {dfid_eqn = HsIB {hsib_body = FamEqn {..}}} ->
117+ DataFamInstDecl {..} -> do
118+ let HsIB {..} = dfid_eqn
119+ FamEqn {..} = hsib_body
110120 p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs
111− DataFamInstDecl {dfid_eqn = HsIB {hsib_body = XFamEqn {}}} ->
112− notImplemented "XFamEqn"
113− DataFamInstDecl {dfid_eqn = XHsImplicitBndrs {}} ->
114− notImplemented "XHsImplicitBndrs"
115121
116122match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R ()
117123match_overlap_mode overlap_mode layoutStrategy =
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+6−2
@@ -1,5 +1,6 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
34{-# LANGUAGE TypeFamilies #-}
45
56-- | Rendering of Role annotation declarations.
@@ -12,11 +13,14 @@ import CoAxiom
1213import GHC
1314import Ormolu.Printer.Combinators
1415import Ormolu.Printer.Meat.Common
16+import Ormolu.Utils
17+import RdrName (RdrName (..))
18+import SrcLoc (Located)
1519
1620p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()
1721p_roleAnnot = \case
18− RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns
19− XRoleAnnotDecl x -> noExtCon x
22+ RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns
23+ XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"
2024
2125p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()
2226p_roleAnnot' l_name anns = do
src/Ormolu/Printer/Meat/Declaration/Rule.hs+16−21
@@ -1,5 +1,6 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
34
45module Ormolu.Printer.Meat.Declaration.Rule
56 ( p_ruleDecls,
@@ -7,55 +8,49 @@ module Ormolu.Printer.Meat.Declaration.Rule
78where
89
910import BasicTypes
10−import Control.Monad (unless)
11+import Data.Maybe (fromMaybe)
1112import GHC
1213import Ormolu.Printer.Combinators
1314import Ormolu.Printer.Meat.Common
1415import Ormolu.Printer.Meat.Declaration.Signature
1516import Ormolu.Printer.Meat.Declaration.Value
1617import Ormolu.Printer.Meat.Type
18+import Ormolu.Utils
1719
1820p_ruleDecls :: RuleDecls GhcPs -> R ()
1921p_ruleDecls = \case
20− HsRules NoExtField _ xs ->
21− pragma "RULES" $
22+ HsRules NoExt _ xs ->
23+ pragma "RULES" . sitcc $
2224 sep breakpoint (sitcc . located' p_ruleDecl) xs
23− XRuleDecls x -> noExtCon x
25+ XRuleDecls NoExt -> notImplemented "XRuleDecls"
2426
2527p_ruleDecl :: RuleDecl GhcPs -> R ()
2628p_ruleDecl = \case
27− HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do
29+ HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do
2830 located ruleName p_ruleName
2931 space
3032 p_activation activation
3133 space
32− case tyvars of
33− Nothing -> return ()
34− Just xs -> do
35− p_forallBndrs ForallInvis p_hsTyVarBndr xs
36− space
37− -- It appears that there is no way to tell if there was an empty forall
38− -- in the input or no forall at all. We do not want to add redundant
39− -- foralls, so let's just skip the empty ones.
40− unless (null ruleBndrs) $
41− p_forallBndrs ForallInvis p_ruleBndr ruleBndrs
34+ p_forallBndrs p_hsTyVarBndr (fromMaybe [] tyvars)
35+ space
36+ p_forallBndrs p_ruleBndr ruleBndrs
4237 breakpoint
4338 inci $ do
4439 located lhs p_hsExpr
4540 space
46− equals
41+ txt "="
4742 inci $ do
4843 breakpoint
4944 located rhs p_hsExpr
50− XRuleDecl x -> noExtCon x
45+ XRuleDecl NoExt -> notImplemented "XRuleDecl"
5146
5247p_ruleName :: (SourceText, RuleName) -> R ()
53−p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)
48+p_ruleName (_, name) = atom $ HsString NoSourceText name
5449
5550p_ruleBndr :: RuleBndr GhcPs -> R ()
5651p_ruleBndr = \case
57− RuleBndr NoExtField x -> p_rdrName x
58− RuleBndrSig NoExtField x hswc -> parens N $ do
52+ RuleBndr NoExt x -> p_rdrName x
53+ RuleBndrSig NoExt x hswc -> parens N $ do
5954 p_rdrName x
6055 p_typeAscription hswc
61− XRuleBndr x -> noExtCon x
56+ XRuleBndr NoExt -> notImplemented "XRuleBndr"
src/Ormolu/Printer/Meat/Declaration/Signature.hs+33−49
@@ -7,13 +7,13 @@ module Ormolu.Printer.Meat.Declaration.Signature
77 ( p_sigDecl,
88 p_typeAscription,
99 p_activation,
10− p_standaloneKindSig,
1110 )
1211where
1312
1413import BasicTypes
1514import BooleanFormula
1615import 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 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
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
3535 _ -> notImplemented "certain types of signature declarations"
3636
3737p_typeSig ::
@@ -47,23 +47,25 @@ p_typeSig indentTail (n : ns) hswc = do
4747 p_rdrName n
4848 if null ns
4949 then p_typeAscription hswc
50− else inciIf indentTail $ do
51− commaDel
52− sep commaDel p_rdrName ns
50+ else bool id inci indentTail $ do
51+ comma
52+ breakpoint
53+ sep (comma >> breakpoint) p_rdrName ns
5354 p_typeAscription hswc
5455
5556p_typeAscription ::
5657 LHsSigWcType GhcPs ->
5758 R ()
58−p_typeAscription HsWC {..} = inci $ do
59+p_typeAscription HsWC {..} = do
5960 space
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
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"
6769
6870p_patSynSig ::
6971 [Located RdrName] ->
@@ -71,11 +73,7 @@ p_patSynSig ::
7173 R ()
7274p_patSynSig names hsib = do
7375 txt "pattern"
74− let body =
75− p_typeSig
76− False
77− names
78− HsWC {hswc_ext = NoExtField, hswc_body = hsib}
76+ let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}
7977 if length names > 1
8078 then breakpoint >> inci body
8179 else space >> body
@@ -90,13 +88,13 @@ p_classOpSig ::
9088 R ()
9189p_classOpSig def names hsib = do
9290 when def (txt "default" >> space)
93− p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
91+ p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}
9492
9593p_fixSig ::
9694 FixitySig GhcPs ->
9795 R ()
9896p_fixSig = \case
99− FixitySig NoExtField names (Fixity _ n dir) -> do
97+ FixitySig NoExt names (Fixity _ n dir) -> do
10098 txt $ case dir of
10199 InfixL -> "infixl"
102100 InfixR -> "infixr"
@@ -104,8 +102,8 @@ p_fixSig = \case
104102 space
105103 atom n
106104 space
107− sitcc $ sep commaDel p_rdrName names
108− XFixitySig x -> noExtCon x
105+ sitcc $ sep (comma >> breakpoint) p_rdrName names
106+ XFixitySig NoExt -> notImplemented "XFixitySig"
109107
110108p_inlineSig ::
111109 -- | Name
@@ -143,7 +141,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do
143141 space
144142 txt "::"
145143 breakpoint
146− inci $ sep commaDel (located' p_hsType . hsib_body) ts
144+ inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts
147145
148146p_inlineSpec :: InlineSpec -> R ()
149147p_inlineSpec = \case
@@ -187,13 +185,13 @@ p_booleanFormula = \case
187185 And xs ->
188186 sitcc $
189187 sep
190− commaDel
188+ (comma >> breakpoint)
191189 (located' p_booleanFormula)
192190 xs
193191 Or xs ->
194192 sitcc $
195193 sep
196− (breakpoint >> txt "|" >> space)
194+ (breakpoint >> txt "| ")
197195 (located' p_booleanFormula)
198196 xs
199197 Parens l -> located l (parens N . p_booleanFormula)
@@ -207,7 +205,7 @@ p_completeSig ::
207205p_completeSig cs' mty =
208206 located cs' $ \cs ->
209207 pragma "COMPLETE" . inci $ do
210− sep commaDel p_rdrName cs
208+ sitcc $ sep (comma >> breakpoint) p_rdrName cs
211209 forM_ mty $ \ty -> do
212210 space
213211 txt "::"
@@ -220,17 +218,3 @@ p_sccSig loc literal = pragma "SCC" . inci $ do
220218 forM_ literal $ \x -> do
221219 breakpoint
222220 atom x
223−
224−p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
225−p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do
226− txt "type"
227− inci $ do
228− space
229− p_rdrName name
230− space
231− txt "::"
232− breakpoint
233− case bndrs of
234− HsIB NoExtField sig -> located sig p_hsType
235− XHsImplicitBndrs x -> noExtCon x
236−p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c
src/Ormolu/Printer/Meat/Declaration/Splice.hs+3−2
@@ -8,8 +8,9 @@ where
88import GHC
99import Ormolu.Printer.Combinators
1010import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
11+import Ormolu.Utils
1112
1213p_spliceDecl :: SpliceDecl GhcPs -> R ()
1314p_spliceDecl = \case
14− SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice
15− XSpliceDecl x -> noExtCon x
15+ SpliceDecl NoExt splice _explicit -> located splice p_hsSplice
16+ XSpliceDecl {} -> notImplemented "XSpliceDecl"
src/Ormolu/Printer/Meat/Declaration/Type.hs+8−8
@@ -11,6 +11,8 @@ import GHC
1111import Ormolu.Printer.Combinators
1212import Ormolu.Printer.Meat.Common
1313import Ormolu.Printer.Meat.Type
14+import RdrName (RdrName (..))
15+import SrcLoc (Located)
1416
1517p_synDecl ::
1618 -- | Type constructor
@@ -22,19 +24,17 @@ p_synDecl ::
2224 -- | RHS of type declaration
2325 LHsType GhcPs ->
2426 R ()
25−p_synDecl name fixity HsQTvs {..} t = do
27+p_synDecl name fixity tvars t = do
2628 txt "type"
2729 space
28− switchLayout (getLoc name : map getLoc hsq_explicit) $
30+ let HsQTvs {..} = tvars
31+ switchLayout (getLoc name : map getLoc hsq_explicit) $ do
2932 p_infixDefHelper
3033 (case fixity of Infix -> True; _ -> False)
31− True
34+ inci
3235 (p_rdrName name)
3336 (map (located' p_hsTyVarBndr) hsq_explicit)
3437 space
35− equals
36− if hasDocStrings (unLoc t)
37− then newline
38− else breakpoint
38+ txt "="
39+ breakpoint
3940 inci (located t p_hsType)
40−p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+28−27
@@ -9,16 +9,18 @@ module Ormolu.Printer.Meat.Declaration.TypeFamily
99 )
1010where
1111
12+import BasicTypes (LexicalFixity (..))
1213import Control.Monad
13−import Data.Maybe (isNothing)
14+import Data.Maybe (isJust, isNothing)
1415import GHC
1516import Ormolu.Printer.Combinators
1617import Ormolu.Printer.Meat.Common
1718import Ormolu.Printer.Meat.Type
1819import Ormolu.Utils
20+import SrcLoc (GenLocated (..), Located)
1921
2022p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()
21−p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
23+p_famDecl style FamilyDecl {..} = do
2224 mmeqs <- case fdInfo of
2325 DataFamily -> Nothing <$ txt "data"
2426 OpenTypeFamily -> Nothing <$ txt "type"
@@ -26,26 +28,27 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
2628 txt $ case style of
2729 Associated -> mempty
2830 Free -> " family"
31+ let HsQTvs {..} = fdTyVars
2932 breakpoint
3033 inci $ do
31− switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $
34+ switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $ do
3235 p_infixDefHelper
3336 (isInfix fdFixity)
34− True
37+ inci
3538 (p_rdrName fdLName)
3639 (located' p_hsTyVarBndr <$> hsq_explicit)
37− let resultSig = p_familyResultSigL fdResultSig
38− unless (isNothing resultSig && isNothing fdInjectivityAnn) space
39− inci $ do
40− sequence_ resultSig
40+ let rsig = p_familyResultSigL fdResultSig
41+ unless (isNothing rsig && isNothing fdInjectivityAnn) $
4142 space
43+ inci $ do
44+ sequence_ rsig
45+ when (isJust rsig && isJust fdInjectivityAnn) breakpoint
4246 forM_ fdInjectivityAnn (located' p_injectivityAnn)
4347 case mmeqs of
4448 Nothing -> return ()
4549 Just meqs -> do
46− inci $ do
47− breakpoint
48− txt "where"
50+ space
51+ txt "where"
4952 case meqs of
5053 Nothing -> do
5154 space
@@ -53,9 +56,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do
5356 Just eqs -> do
5457 newline
5558 sep newline (located' (inci . p_tyFamInstEqn)) eqs
56−p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =
57− notImplemented "XLHsQTyVars"
58−p_famDecl _ (XFamilyDecl x) = noExtCon x
59+p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"
5960
6061p_familyResultSigL ::
6162 Located (FamilyResultSig GhcPs) ->
@@ -63,17 +64,17 @@ p_familyResultSigL ::
6364p_familyResultSigL l =
6465 case l of
6566 L _ a -> case a of
66− NoSig NoExtField -> Nothing
67− KindSig NoExtField k -> Just $ do
67+ NoSig NoExt -> Nothing
68+ KindSig NoExt k -> Just $ do
6869 txt "::"
6970 breakpoint
7071 located k p_hsType
71− TyVarSig NoExtField bndr -> Just $ do
72− equals
72+ TyVarSig NoExt bndr -> Just $ do
73+ txt "="
7374 breakpoint
7475 located bndr p_hsTyVarBndr
75− XFamilyResultSig x ->
76− noExtCon x
76+ XFamilyResultSig NoExt ->
77+ notImplemented "XFamilyResultSig"
7778
7879p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
7980p_injectivityAnn (InjectivityAnn a bs) = do
@@ -86,26 +87,26 @@ p_injectivityAnn (InjectivityAnn a bs) = do
8687 sep space p_rdrName bs
8788
8889p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
89−p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
90+p_tyFamInstEqn HsIB {..} = do
91+ let FamEqn {..} = hsib_body
9092 case feqn_bndrs of
9193 Nothing -> return ()
9294 Just bndrs -> do
93− p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
95+ p_forallBndrs p_hsTyVarBndr bndrs
9496 breakpoint
95− inciIf (not $ null feqn_bndrs) $ do
97+ (if null feqn_bndrs then id else inci) $ do
9698 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
9799 switchLayout famLhsSpn $
98100 p_infixDefHelper
99101 (isInfix feqn_fixity)
100− True
102+ inci
101103 (p_rdrName feqn_tycon)
102104 (located' p_hsType . typeArgToType <$> feqn_pats)
103105 space
104− equals
106+ txt "="
105107 breakpoint
106108 inci (located feqn_rhs p_hsType)
107−p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
108−p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
109+p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
109110
110111----------------------------------------------------------------------------
111112-- Helpers
src/Ormolu/Printer/Meat/Declaration/Value.hs+357−435
@@ -1,8 +1,6 @@
11{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MultiWayIf #-}
32{-# LANGUAGE OverloadedStrings #-}
43{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE TypeApplications #-}
64
75module Ormolu.Printer.Meat.Declaration.Value
86 ( p_valDecl,
@@ -20,22 +18,23 @@ import Ctype (is_space)
2018import Data.Bool (bool)
2119import Data.Char (isPunctuation, isSymbol)
2220import Data.Data hiding (Infix, Prefix)
23−import Data.Functor ((<&>))
2421import Data.List (intersperse, sortOn)
25−import Data.List.NonEmpty (NonEmpty (..), (<|))
22+import Data.List.NonEmpty ((<|), NonEmpty ((:|)))
2623import qualified Data.List.NonEmpty as NE
2724import Data.Text (Text)
2825import qualified Data.Text as Text
2926import GHC
30−import OccName (occNameString)
27+import OccName (mkVarOcc)
3128import Ormolu.Printer.Combinators
32−import Ormolu.Printer.Internal
3329import Ormolu.Printer.Meat.Common
3430import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
3531import Ormolu.Printer.Meat.Declaration.Signature
3632import Ormolu.Printer.Meat.Type
3733import Ormolu.Printer.Operators
3834import Ormolu.Utils
35+import RdrName (RdrName (..))
36+import RdrName (rdrNameOcc)
37+import SrcLoc (combineSrcSpans, isOneLineSpan)
3938
4039-- | Style of a group of equations.
4140data MatchGroupStyle
@@ -61,16 +60,16 @@ data Placement
6160 -- should use it and avoid bumping one level
6261 -- of indentation
6362 Hanging
64− deriving (Eq, Show)
63+ deriving (Eq)
6564
6665p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
6766p_valDecl = \case
68− FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches
69− PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
67+ FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches
68+ PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss
7069 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker
7170 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker
72− PatSynBind NoExtField psb -> p_patSynBind psb
73− XHsBindsLR x -> noExtCon x
71+ PatSynBind NoExt psb -> p_patSynBind psb
72+ XHsBindsLR NoExt -> notImplemented "XHsBindsLR"
7473
7574p_funBind ::
7675 Located RdrName ->
@@ -100,7 +99,7 @@ p_matchGroup' placer render style MG {..} = do
10099 Case -> id
101100 LambdaCase -> id
102101 _ -> dontUseBraces
103− -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to
102+ -- NOTE since we are forcing braces on 'sepSemi' based on 'ob', we have to
104103 -- restore the brace state inside the sepsemi.
105104 ub <- bool dontUseBraces useBraces <$> canUseBraces
106105 ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts)
@@ -114,8 +113,8 @@ p_matchGroup' placer render style MG {..} = do
114113 (matchStrictness m)
115114 m_pats
116115 m_grhss
117− p_Match (XMatch x) = noExtCon x
118−p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x
116+ p_Match _ = notImplemented "XMatch"
117+p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"
119118
120119-- | Function id obtained through pattern matching on 'FunBind' should not
121120-- be used to print the actual equations because the different ‘RdrNames’
@@ -168,9 +167,9 @@ p_match' ::
168167 -- | Equations
169168 GRHSs GhcPs (Located body) ->
170169 R ()
171−p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
172− -- Normally, since patterns may be placed in a multi-line layout, it is
173− -- necessary to bump indentation for the pattern group so it's more
170+p_match' placer render style isInfix strictness m_pats m_grhss = do
171+ -- NOTE Normally, since patterns may be placed in a multi-line layout, it
172+ -- is necessary to bump indentation for the pattern group so it's more
174173 -- indented than function name. This in turn means that indentation for
175174 -- the body should also be bumped. Normally this would mean that bodies
176175 -- would start with two indentation steps applied, which is ugly, so we
@@ -180,26 +179,27 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
180179 NoSrcStrict -> return ()
181180 SrcStrict -> txt "!"
182181 SrcLazy -> txt "~"
183− indentBody <- case NE.nonEmpty m_pats of
184− Nothing ->
185− False <$ case style of
186− Function name -> p_rdrName name
187− _ -> return ()
182+ inci' <- case NE.nonEmpty m_pats of
183+ Nothing -> id <$ case style of
184+ Function name -> p_rdrName name
185+ _ -> return ()
188186 Just ne_pats -> do
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)
187+ let combinedSpans =
188+ combineSrcSpans' $
189+ getLoc <$> ne_pats
190+ inci' =
191+ if isOneLineSpan combinedSpans
192+ then id
193+ else inci
194194 switchLayout [combinedSpans] $ do
195− let stdCase = sep breakpoint (located' p_pat) m_pats
195+ let stdCase = sep breakpoint p_pat m_pats
196196 case style of
197197 Function name ->
198198 p_infixDefHelper
199199 isInfix
200− indentBody
200+ inci'
201201 (p_rdrName name)
202− (located' p_pat <$> m_pats)
202+ (p_pat <$> m_pats)
203203 PatternBind -> stdCase
204204 Case -> stdCase
205205 Lambda -> do
@@ -212,32 +212,41 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
212212 when needsSpace space
213213 sitcc stdCase
214214 LambdaCase -> stdCase
215− return indentBody
215+ return inci'
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 (getLoc name)
220+ Function name -> (Just . srcSpanEnd . getLoc) name
221221 _ -> Nothing
222− Just pats -> (Just . getLoc . NE.last) pats
222+ Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats
223223 isCase = \case
224224 Case -> True
225225 LambdaCase -> True
226226 _ -> False
227+ let GRHSs {..} = m_grhss
227228 hasGuards = withGuards grhssGRHSs
228− grhssSpan =
229+ unless (length grhssGRHSs > 1) $ do
230+ case style of
231+ Function _ | hasGuards -> return ()
232+ Function _ -> space >> txt "="
233+ PatternBind -> space >> txt "="
234+ s | isCase s && hasGuards -> return ()
235+ _ -> space >> txt "->"
236+ let grhssSpan =
229237 combineSrcSpans' $
230238 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs
231239 patGrhssSpan =
232240 maybe
233241 grhssSpan
234− (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)
242+ (combineSrcSpans grhssSpan . srcLocSpan)
235243 endOfPats
236244 placement =
237245 case endOfPats of
238246 Nothing -> blockPlacement placer grhssGRHSs
239247 Just spn ->
240− if onTheSameLine spn grhssSpan
248+ if isOneLineSpan
249+ (mkSrcSpan spn (srcSpanStart grhssSpan))
241250 then blockPlacement placer grhssGRHSs
242251 else Normal
243252 p_body = do
@@ -253,18 +262,10 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
253262 txt "where"
254263 unless whereIsEmpty breakpoint
255264 inci $ located grhssLocalBinds p_hsLocalBinds
256− inciIf indentBody $ do
257− unless (length grhssGRHSs > 1) $
258− case style of
259− Function _ | hasGuards -> return ()
260− Function _ -> space >> inci equals
261− PatternBind -> space >> inci equals
262− s | isCase s && hasGuards -> return ()
263− _ -> space >> txt "->"
265+ inci' $ do
264266 switchLayout [patGrhssSpan] $
265267 placeHanging placement p_body
266268 inci p_where
267−p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
268269
269270p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
270271p_grhs = p_grhs' exprPlacement p_hsExpr
@@ -278,109 +279,79 @@ p_grhs' ::
278279 GroupStyle ->
279280 GRHS GhcPs (Located body) ->
280281 R ()
281−p_grhs' placer render style (GRHS NoExtField guards body) =
282+p_grhs' placer render style (GRHS NoExt guards body) =
282283 case guards of
283284 [] -> p_body
284285 xs -> do
285286 txt "|"
286287 space
287− sitcc (sep commaDel (sitcc . located' p_stmt) xs)
288+ sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
288289 space
289− inci $ case style of
290− EqualSign -> equals
291− RightArrow -> txt "->"
290+ txt $ case style of
291+ EqualSign -> "="
292+ RightArrow -> "->"
292293 placeHanging placement p_body
293294 where
294295 placement =
295296 case endOfGuards of
296297 Nothing -> placer (unLoc body)
297298 Just spn ->
298− if onTheSameLine spn (getLoc body)
299+ if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
299300 then placer (unLoc body)
300301 else Normal
301302 endOfGuards =
302303 case NE.nonEmpty guards of
303304 Nothing -> Nothing
304− Just gs -> (Just . getLoc . NE.last) gs
305+ Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
305306 p_body = located body render
306−p_grhs' _ _ _ (XGRHS x) = noExtCon x
307+p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
307308
308309p_hsCmd :: HsCmd GhcPs -> R ()
309310p_hsCmd = \case
310− HsCmdArrApp NoExtField body input arrType _ -> do
311+ HsCmdArrApp NoExt body input arrType _ -> do
311312 located body p_hsExpr
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
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
320320 located form p_hsExpr
321321 unless (null cmds) $ do
322322 breakpoint
323323 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
324− HsCmdArrForm NoExtField form Infix _ [left, right] -> do
324+ HsCmdArrForm NoExt 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 NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
330+ HsCmdArrForm NoExt _ 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 NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
336− HsCmdPar NoExtField c -> parens N (located c p_hsCmd)
337− HsCmdCase NoExtField e mgroup ->
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 ->
338338 p_case cmdPlacement p_hsCmd e mgroup
339− HsCmdIf NoExtField _ if' then' else' ->
339+ HsCmdIf NoExt _ if' then' else' ->
340340 p_if cmdPlacement p_hsCmd if' then' else'
341− HsCmdLet NoExtField localBinds c ->
341+ HsCmdLet NoExt localBinds c ->
342342 p_let p_hsCmd localBinds c
343− HsCmdDo NoExtField es -> do
343+ HsCmdDo NoExt es -> do
344344 txt "do"
345345 newline
346346 inci . located es $
347− sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))
347+ sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
348348 HsCmdWrap {} -> notImplemented "HsCmdWrap"
349− XCmd x -> noExtCon x
349+ XCmd {} -> notImplemented "XCmd"
350350
351351p_hsCmdTop :: HsCmdTop GhcPs -> R ()
352352p_hsCmdTop = \case
353− HsCmdTop NoExtField cmd -> located cmd p_hsCmd
354− XCmdTop x -> noExtCon x
355−
356−-- | Render an expression preserving blank lines between such consecutive
357−-- expressions found in the original source code.
358−withSpacing ::
359− -- | Rendering function
360− (a -> R ()) ->
361− -- | Entity to render
362− Located a ->
363− R ()
364−withSpacing f l = located l $ \x -> do
365− case getLoc l of
366− UnhelpfulSpan _ -> f x
367− RealSrcSpan currentSpn -> do
368− getSpanMark >>= \case
369− -- Spacing before comments will be handled by the code
370− -- that prints comments, so we just have to deal with
371− -- blank lines between statements here.
372− Just (StatementSpan lastSpn) ->
373− if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1
374− then newline
375− else return ()
376− _ -> return ()
377− f x
378− -- In some cases the (f x) expression may insert a new mark. We want
379− -- to be careful not to override comment marks.
380− getSpanMark >>= \case
381− Just (HaddockSpan _ _) -> return ()
382− Just (CommentSpan _) -> return ()
383− _ -> setSpanMark (StatementSpan currentSpn)
353+ HsCmdTop NoExt cmd -> located cmd p_hsCmd
354+ XCmdTop {} -> notImplemented "XHsCmdTop"
384355
385356p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
386357p_stmt = p_stmt' exprPlacement p_hsExpr
@@ -395,13 +366,16 @@ p_stmt' ::
395366 Stmt GhcPs (Located body) ->
396367 R ()
397368p_stmt' placer render = \case
398− LastStmt NoExtField body _ _ -> located body render
399− BindStmt NoExtField p f _ _ -> do
400− located p p_pat
369+ LastStmt NoExt body _ _ -> located body render
370+ BindStmt NoExt p f _ _ -> do
371+ p_pat p
401372 space
402373 txt "<-"
403− let loc = getLoc p
404− placement =
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 =
405379 case f of
406380 L l' x ->
407381 if isOneLineSpan
@@ -411,20 +385,20 @@ p_stmt' placer render = \case
411385 switchLayout [loc, getLoc f] $
412386 placeHanging placement (located f render)
413387 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
414− BodyStmt NoExtField body _ _ -> located body render
415− LetStmt NoExtField binds -> do
388+ BodyStmt NoExt body _ _ -> located body render
389+ LetStmt NoExt binds -> do
416390 txt "let"
417391 space
418392 sitcc $ located binds p_hsLocalBinds
419393 ParStmt {} ->
420− -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such
421− -- that it never occurs in 'p_stmt''. Consequently, handling it here
422− -- would be redundant.
394+ -- NOTE 'ParStmt' should always be eliminated in 'gatherStmt' already,
395+ -- such that it never occurs in 'p_stmt''. Consequently, handling it
396+ -- here would be redundant.
423397 notImplemented "ParStmt"
424− TransStmt {..} ->
425− -- 'TransStmt' only needs to account for render printing itself, since
426− -- pretty printing of relevant statements (e.g., in 'trS_stmts') is
427− -- handled through 'gatherStmt'.
398+ TransStmt {..} -> do
399+ -- NOTE 'TransStmt' only needs to account for render printing itself,
400+ -- since pretty printing of relevant statements (e.g., in 'trS_stmts')
401+ -- is handled through 'gatherStmt'.
428402 case (trS_form, trS_by) of
429403 (ThenForm, Nothing) -> do
430404 txt "then"
@@ -453,11 +427,11 @@ p_stmt' placer render = \case
453427 RecStmt {..} -> do
454428 txt "rec"
455429 space
456− sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
457− XStmtLR c -> noExtCon c
430+ sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
431+ XStmtLR {} -> notImplemented "XStmtLR"
458432
459433gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
460−gatherStmt (L _ (ParStmt NoExtField block _ _)) =
434+gatherStmt (L _ (ParStmt NoExt block _ _)) =
461435 foldr ((<>) . gatherStmtBlock) [] block
462436gatherStmt (L s stmt@TransStmt {..}) =
463437 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
@@ -466,93 +440,96 @@ gatherStmt stmt = [[stmt]]
466440gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
467441gatherStmtBlock (ParStmtBlock _ stmts _ _) =
468442 foldr (liftAppend . gatherStmt) [] stmts
469−gatherStmtBlock (XParStmtBlock x) = noExtCon x
443+gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
470444
471445p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
472446p_hsLocalBinds = \case
473− HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
474− -- When in a single-line layout, there is a chance that the inner
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
461+ -- NOTE When in a single-line layout, there is a chance that the inner
475462 -- elements will also contain semicolons and they will confuse the
476463 -- parser. so we request braces around every element except the last.
477464 br <- layoutToBraces <$> getLayout
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) ->
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) ->
494471 -- Second argument of IPBind is always Left before type-checking.
495− let p_ipBind (IPBind NoExtField (Left name) expr) = do
472+ let p_ipBind (IPBind NoExt (Left name) expr) = do
496473 atom name
497474 space
498− equals
475+ txt "="
499476 breakpoint
500477 useBraces $ inci $ located expr p_hsExpr
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
478+ p_ipBind _ = notImplemented "XHsIPBinds"
505479 in sepSemi (located' p_ipBind) xs
506− HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
507− EmptyLocalBinds NoExtField -> return ()
508− XHsLocalBindsLR x -> noExtCon x
480+ HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
481+ EmptyLocalBinds NoExt -> return ()
482+ XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
509483
510484p_hsRecField ::
511485 HsRecField' RdrName (LHsExpr GhcPs) ->
512486 R ()
513−p_hsRecField HsRecField {..} = do
487+p_hsRecField = \HsRecField {..} -> do
514488 p_rdrName hsRecFieldLbl
515489 unless hsRecPun $ do
516490 space
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)
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"
523500
524501p_hsExpr :: HsExpr GhcPs -> R ()
525502p_hsExpr = p_hsExpr' N
526503
527504p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
528505p_hsExpr' s = \case
529− HsVar NoExtField name -> p_rdrName name
530− HsUnboundVar NoExtField v -> atom (unboundVarOcc v)
531− HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"
532− HsRecFld NoExtField x ->
506+ HsVar NoExt name -> p_rdrName name
507+ HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
508+ HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
509+ HsRecFld NoExt x ->
533510 case x of
534− Unambiguous NoExtField name -> p_rdrName name
535− Ambiguous NoExtField name -> p_rdrName name
536− XAmbiguousFieldOcc xx -> noExtCon xx
537− HsOverLabel NoExtField _ v -> do
511+ Unambiguous NoExt name -> p_rdrName name
512+ Ambiguous NoExt name -> p_rdrName name
513+ XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
514+ HsOverLabel NoExt _ v -> do
538515 txt "#"
539516 atom v
540− HsIPVar NoExtField (HsIPName name) -> do
517+ HsIPVar NoExt (HsIPName name) -> do
541518 txt "?"
542519 atom name
543− HsOverLit NoExtField v -> atom (ol_val v)
544− HsLit NoExtField lit ->
520+ HsOverLit NoExt v -> atom (ol_val v)
521+ HsLit NoExt lit ->
545522 case lit of
546523 HsString (SourceText stxt) _ -> p_stringLit stxt
547524 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
548525 r -> atom r
549− HsLam NoExtField mgroup ->
526+ HsLam NoExt mgroup ->
550527 p_matchGroup Lambda mgroup
551− HsLamCase NoExtField mgroup -> do
528+ HsLamCase NoExt mgroup -> do
552529 txt "\\case"
553530 breakpoint
554531 inci (p_matchGroup LambdaCase mgroup)
555− HsApp NoExtField f x -> do
532+ HsApp NoExt f x -> do
556533 let -- In order to format function applications with multiple parameters
557534 -- nicer, traverse the AST to gather the function and all the
558535 -- parameters together.
@@ -564,10 +541,8 @@ p_hsExpr' s = \case
564541 -- We need to handle the last argument specially if it is a
565542 -- hanging construct, so separate it from the rest.
566543 (initp, lastp) = (NE.init args, NE.last args)
567− initSpan =
568− combineSrcSpans' $
569− getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]
570− -- Hang the last argument only if the initial arguments span one
544+ initSpan = combineSrcSpans' $ getLoc f :| map getLoc initp
545+ -- Hang the last argument only if the initial arguments spans one
571546 -- line.
572547 placement =
573548 if isOneLineSpan initSpan
@@ -579,26 +554,11 @@ p_hsExpr' s = \case
579554 -- one.
580555 case placement of
581556 Normal -> do
582− let -- Usually we want to bump indentation for arguments for the
583− -- sake of readability. However, when the function itself is a
584− -- do-block or case expression it is not a good idea. It seems
585− -- to be safe to always bump indentation when the function
586− -- expression is parenthesised.
587− doIndent =
588− case func of
589− L _ (HsPar NoExtField _) -> True
590− L _ (HsAppType NoExtField _ _) -> True
591− L _ (HsMultiIf NoExtField _) -> True
592− L spn _ -> isOneLineSpan spn
593− ub <-
594− getLayout <&> \case
595− SingleLine -> useBraces
596− MultiLine -> id
597− ub $ do
557+ useBraces $ do
598558 located func (p_hsExpr' s)
599559 breakpoint
600− inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601− inciIf doIndent $ do
560+ inci $ sep breakpoint (located' p_hsExpr) initp
561+ inci $ do
602562 unless (null initp) breakpoint
603563 located lastp p_hsExpr
604564 Hanging -> do
@@ -608,87 +568,75 @@ p_hsExpr' s = \case
608568 sep breakpoint (located' p_hsExpr) initp
609569 placeHanging placement $
610570 located lastp p_hsExpr
611− HsAppType NoExtField e a -> do
571+ HsAppType NoExt e a -> do
612572 located e p_hsExpr
613573 breakpoint
614574 inci $ do
615575 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 ()
621576 located (hswc_body a) p_hsType
622− OpApp NoExtField x op y -> do
577+ OpApp NoExt x op y -> do
623578 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
624− p_exprOpTree s (reassociateOpTree getOpName opTree)
625− NegApp NoExtField e _ -> do
579+ p_exprOpTree True s (reassociateOpTree getOpName opTree)
580+ NegApp NoExt e _ -> do
626581 txt "-"
627582 space
628583 located e p_hsExpr
629− HsPar NoExtField e ->
584+ HsPar NoExt e ->
630585 parens s (located e (dontUseBraces . p_hsExpr))
631− SectionL NoExtField x op -> do
586+ SectionL NoExt x op -> do
632587 located x p_hsExpr
633588 breakpoint
634589 inci (located op p_hsExpr)
635− SectionR NoExtField op x -> do
590+ SectionR NoExt op x -> do
636591 located op p_hsExpr
637− useRecordDot' <- useRecordDot
638− let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
639− unless (useRecordDot' && isRecordDot') breakpoint
592+ breakpoint
640593 inci (located x p_hsExpr)
641− ExplicitTuple NoExtField args boxity ->
594+ ExplicitTuple NoExt args boxity -> do
642595 let isSection = any (isMissing . unLoc) args
643596 isMissing = \case
644− Missing NoExtField -> True
597+ Missing NoExt -> True
645598 _ -> False
646− p_arg = \case
647− Present NoExtField x -> located x p_hsExpr
648− Missing NoExtField -> pure ()
649− XTupArg x -> noExtCon x
650− p_larg = sitcc . located' p_arg
651− parens' =
599+ let parens' =
652600 case boxity of
653601 Boxed -> parens
654602 Unboxed -> parensHash
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 ->
603+ if isSection
604+ then
605+ switchLayout [] . parens' s $
606+ sep comma (located' p_hsTupArg) args
607+ else
608+ switchLayout (getLoc <$> args) . parens' s . sitcc $
609+ sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
610+ ExplicitSum NoExt tag arity e ->
663611 p_unboxedSum N tag arity (located e p_hsExpr)
664− HsCase NoExtField e mgroup ->
612+ HsCase NoExt e mgroup ->
665613 p_case exprPlacement p_hsExpr e mgroup
666− HsIf NoExtField _ if' then' else' ->
614+ HsIf NoExt _ if' then' else' ->
667615 p_if exprPlacement p_hsExpr if' then' else'
668− HsMultiIf NoExtField guards -> do
616+ HsMultiIf NoExt guards -> do
669617 txt "if"
670618 breakpoint
671− inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
672− HsLet NoExtField localBinds e ->
619+ inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
620+ HsLet NoExt localBinds e ->
673621 p_let p_hsExpr localBinds e
674− HsDo NoExtField ctx es -> do
622+ HsDo NoExt ctx es -> do
675623 let doBody header = do
676624 txt header
677625 breakpoint
678626 ub <- layoutToBraces <$> getLayout
679627 inci $
680628 sepSemi
681− (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
629+ (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
682630 (unLoc es)
683− compBody = brackets N . located es $ \xs -> do
631+ compBody = brackets N $ located es $ \xs -> do
684632 let p_parBody =
685633 sep
686− (breakpoint >> txt "|" >> space)
634+ (breakpoint >> txt "| ")
687635 p_seqBody
688636 p_seqBody =
689637 sitcc
690638 . sep
691− commaDel
639+ (comma >> breakpoint)
692640 (located' (sitcc . p_stmt))
693641 stmts = init xs
694642 yield = last xs
@@ -709,96 +657,90 @@ p_hsExpr' s = \case
709657 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
710658 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
711659 ExplicitList _ _ xs ->
712− brackets s $
713− sep commaDel (sitcc . located' p_hsExpr) xs
660+ brackets s . sitcc $
661+ sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
714662 RecordCon {..} -> do
715663 located rcon_con_name atom
716664 breakpoint
717665 let HsRecFields {..} = rcon_flds
718666 updName f =
719− (f :: HsRecField GhcPs (LHsExpr GhcPs))
667+ f
720668 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
721669 FieldOcc _ n -> n
722− XFieldOcc x -> noExtCon x
670+ XFieldOcc _ -> notImplemented "XFieldOcc"
723671 }
724672 fields = located' (p_hsRecField . updName) <$> rec_flds
725673 dotdot =
726674 case rec_dotdot of
727675 Just {} -> [txt ".."]
728676 Nothing -> []
729− inci . braces N $
730− sep commaDel sitcc (fields <> dotdot)
677+ inci . braces N . sitcc $
678+ sep (comma >> breakpoint) sitcc (fields <> dotdot)
731679 RecordUpd {..} -> do
732680 located rupd_expr p_hsExpr
733− useRecordDot' <- useRecordDot
734− let mrs sp = case getLoc sp of
735− RealSrcSpan r -> Just r
736− _ -> Nothing
737− let isPluginForm =
738− ((1 +) . srcSpanEndCol <$> mrs rupd_expr)
739− == (srcSpanStartCol <$> mrs (head rupd_flds))
740− unless (useRecordDot' && isPluginForm) breakpoint
681+ breakpoint
741682 let updName f =
742− (f :: HsRecUpdField GhcPs)
683+ f
743684 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
744685 Ambiguous _ n -> n
745686 Unambiguous _ n -> n
746− XAmbiguousFieldOcc x -> noExtCon x
687+ XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
747688 }
748− inci . braces N $
689+ inci . braces N . sitcc $
749690 sep
750− commaDel
691+ (comma >> breakpoint)
751692 (sitcc . located' (p_hsRecField . updName))
752693 rupd_flds
753− ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
694+ ExprWithTySig NoExt x affix -> sitcc $ do
754695 located x p_hsExpr
755696 space
756697 txt "::"
757698 breakpoint
758− inci $ located hsib_body p_hsType
759− ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x
760− ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x
761− ArithSeq NoExtField _ x ->
699+ inci $ do
700+ let HsWC {..} = affix
701+ HsIB {..} = hswc_body
702+ located hsib_body p_hsType
703+ ArithSeq NoExt _ x -> do
762704 case x of
763− From from -> brackets s $ do
705+ From from -> brackets s . sitcc $ do
764706 located from p_hsExpr
765707 breakpoint
766708 txt ".."
767− FromThen from next -> brackets s $ do
768− sep commaDel (located' p_hsExpr) [from, next]
709+ FromThen from next -> brackets s . sitcc $ do
710+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
769711 breakpoint
770712 txt ".."
771− FromTo from to -> brackets s $ do
713+ FromTo from to -> brackets s . sitcc $ do
772714 located from p_hsExpr
773715 breakpoint
774716 txt ".."
775717 space
776718 located to p_hsExpr
777− FromThenTo from next to -> brackets s $ do
778− sep commaDel (located' p_hsExpr) [from, next]
719+ FromThenTo from next to -> brackets s . sitcc $ do
720+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
779721 breakpoint
780722 txt ".."
781723 space
782724 located to p_hsExpr
783− HsSCC NoExtField _ name x -> do
725+ HsSCC NoExt _ name x -> do
784726 txt "{-# SCC "
785727 atom name
786728 txt " #-}"
787729 breakpoint
788730 located x p_hsExpr
789− HsCoreAnn NoExtField _ value x -> do
731+ HsCoreAnn NoExt _ value x -> do
790732 txt "{-# CORE "
791733 atom value
792734 txt " #-}"
793735 breakpoint
794736 located x p_hsExpr
795− HsBracket NoExtField x -> p_hsBracket x
737+ HsBracket NoExt x -> p_hsBracket x
796738 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
797739 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
798− HsSpliceE NoExtField splice -> p_hsSplice splice
799− HsProc NoExtField p e -> do
740+ HsSpliceE NoExt splice -> p_hsSplice splice
741+ HsProc NoExt p e -> do
800742 txt "proc"
801− located p $ \x -> do
743+ locatedPat p $ \x -> do
802744 breakpoint
803745 inci (p_pat x)
804746 breakpoint
@@ -809,11 +751,31 @@ p_hsExpr' s = \case
809751 txt "static"
810752 breakpoint
811753 inci (located e p_hsExpr)
754+ HsArrApp NoExt body input arrType cond ->
755+ p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
756+ HsArrForm NoExt form mfixity cmds ->
757+ p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
812758 HsTick {} -> notImplemented "HsTick"
813759 HsBinTick {} -> notImplemented "HsBinTick"
814760 HsTickPragma {} -> notImplemented "HsTickPragma"
761+ -- These four constructs should never appear in correct programs.
762+ -- See: https://github.com/tweag/ormolu/issues/343
763+ EWildPat NoExt -> txt "_"
764+ EAsPat NoExt n p -> do
765+ p_rdrName n
766+ txt "@"
767+ located p p_hsExpr
768+ EViewPat NoExt p e -> do
769+ located p p_hsExpr
770+ space
771+ txt "->"
772+ breakpoint
773+ inci (located e p_hsExpr)
774+ ELazyPat NoExt p -> do
775+ txt "~"
776+ located p p_hsExpr
815777 HsWrap {} -> notImplemented "HsWrap"
816− XExpr x -> noExtCon x
778+ XExpr {} -> notImplemented "XExpr"
817779
818780p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
819781p_patSynBind PSB {..} = do
@@ -823,15 +785,15 @@ p_patSynBind PSB {..} = do
823785 Unidirectional -> do
824786 txt "<-"
825787 breakpoint
826− located psb_def p_pat
788+ p_pat psb_def
827789 ImplicitBidirectional -> do
828− equals
790+ txt "="
829791 breakpoint
830− located psb_def p_pat
792+ p_pat psb_def
831793 ExplicitBidirectional mgroup -> do
832794 txt "<-"
833795 breakpoint
834− located psb_def p_pat
796+ p_pat psb_def
835797 newline
836798 txt "where"
837799 newline
@@ -852,8 +814,8 @@ p_patSynBind PSB {..} = do
852814 inci $ do
853815 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
854816 unless (null xs) breakpoint
855− braces N $
856− sep commaDel (p_rdrName . recordPatSynPatVar) xs
817+ braces N . sitcc $
818+ sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
857819 rhs
858820 InfixCon l r -> do
859821 switchLayout [getLoc l, getLoc r] $ do
@@ -865,7 +827,7 @@ p_patSynBind PSB {..} = do
865827 space
866828 p_rdrName r
867829 inci rhs
868−p_patSynBind (XPatSynBind x) = noExtCon x
830+p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
869831
870832p_case ::
871833 Data body =>
@@ -876,7 +838,7 @@ p_case ::
876838 -- | Expression
877839 LHsExpr GhcPs ->
878840 -- | Match group
879− MatchGroup GhcPs (Located body) ->
841+ (MatchGroup GhcPs (Located body)) ->
880842 R ()
881843p_case placer render e mgroup = do
882844 txt "case"
@@ -907,12 +869,10 @@ p_if placer render if' then' else' = do
907869 breakpoint
908870 inci $ do
909871 txt "then"
910− space
911872 located then' $ \x ->
912873 placeHanging (placer x) (render x)
913874 breakpoint
914875 txt "else"
915− space
916876 located else' $ \x ->
917877 placeHanging (placer x) (render x)
918878
@@ -934,77 +894,77 @@ p_let render localBinds e = sitcc $ do
934894
935895p_pat :: Pat GhcPs -> R ()
936896p_pat = \case
937− WildPat NoExtField -> txt "_"
938− VarPat NoExtField name -> p_rdrName name
939− LazyPat NoExtField pat -> do
897+ -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always
898+ -- constructed with the 'XPat' constructor, containing a @Located Pat@.
899+ XPat pat -> located pat p_pat
900+ WildPat NoExt -> txt "_"
901+ VarPat NoExt name -> p_rdrName name
902+ LazyPat NoExt pat -> do
940903 txt "~"
941− located pat p_pat
942− AsPat NoExtField name pat -> do
904+ p_pat pat
905+ AsPat NoExt name pat -> do
943906 p_rdrName name
944907 txt "@"
945− located pat p_pat
946− ParPat NoExtField pat ->
947− located pat (parens S . p_pat)
948− BangPat NoExtField pat -> do
908+ p_pat pat
909+ ParPat NoExt pat ->
910+ locatedPat pat (parens S . p_pat)
911+ BangPat NoExt pat -> do
949912 txt "!"
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' =
913+ p_pat pat
914+ ListPat NoExt pats -> do
915+ brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats
916+ TuplePat NoExt pats boxing -> do
917+ let f =
955918 case boxing of
956919 Boxed -> parens S
957920 Unboxed -> parensHash S
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)
921+ f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats
922+ SumPat NoExt pat tag arity ->
923+ p_unboxedSum S tag arity (p_pat pat)
961924 ConPatIn pat details ->
962925 case details of
963926 PrefixCon xs -> sitcc $ do
964927 p_rdrName pat
965928 unless (null xs) $ do
966929 breakpoint
967− inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs
930+ inci . sitcc $ sep breakpoint (sitcc . p_pat) xs
968931 RecCon (HsRecFields fields dotdot) -> do
969932 p_rdrName pat
970933 breakpoint
971934 let f = \case
972935 Nothing -> txt ".."
973936 Just x -> located x p_pat_hsRecField
974− inci . braces N . sep commaDel f $
937+ inci . braces N . sitcc . sep (comma >> breakpoint) f $
975938 case dotdot of
976939 Nothing -> Just <$> fields
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
940+ Just n -> (Just <$> take n fields) ++ [Nothing]
941+ InfixCon x y -> do
942+ p_pat x
943+ space
944+ p_rdrName pat
945+ breakpoint
946+ inci (p_pat y)
986947 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
987− ViewPat NoExtField expr pat -> sitcc $ do
948+ ViewPat NoExt expr pat -> sitcc $ do
988949 located expr p_hsExpr
989950 space
990951 txt "->"
991952 breakpoint
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
953+ inci (p_pat pat)
954+ SplicePat NoExt splice -> p_hsSplice splice
955+ LitPat NoExt p -> atom p
956+ NPat NoExt v _ _ -> located v (atom . ol_val)
957+ NPlusKPat NoExt n k _ _ _ -> sitcc $ do
997958 p_rdrName n
998959 breakpoint
999960 inci $ do
1000961 txt "+"
1001962 space
1002963 located k (atom . ol_val)
1003− SigPat NoExtField pat hswc -> do
1004− located pat p_pat
964+ SigPat NoExt pat hswc -> do
965+ p_pat pat
1005966 p_typeAscription hswc
1006967 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
1007− XPat x -> noExtCon x
1008968
1009969p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
1010970p_pat_hsRecField HsRecField {..} = do
@@ -1012,40 +972,42 @@ p_pat_hsRecField HsRecField {..} = do
1012972 p_rdrName (rdrNameFieldOcc x)
1013973 unless hsRecPun $ do
1014974 space
1015− equals
975+ txt "="
1016976 breakpoint
1017− inci (located hsRecFieldArg p_pat)
977+ inci (p_pat hsRecFieldArg)
1018978
1019979p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()
1020980p_unboxedSum s tag arity m = do
1021981 let before = tag - 1
1022982 after = arity - before - 1
1023983 args = replicate before Nothing <> [Just m] <> replicate after Nothing
1024− f x =
984+ f (x, i) = do
985+ let isFirst = i == 0
986+ isLast = i == arity - 1
1025987 case x :: Maybe (R ()) of
1026988 Nothing ->
1027− space
989+ unless (isFirst || isLast) space
1028990 Just m' -> do
1029− space
991+ unless isFirst space
1030992 m'
1031− space
1032− parensHash s $ sep (txt "|") f args
993+ unless isLast space
994+ parensHash s $ sep (txt "|") f (zip args [0 ..])
1033995
1034996p_hsSplice :: HsSplice GhcPs -> R ()
1035997p_hsSplice = \case
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
998+ HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
999+ HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
1000+ HsQuasiQuote NoExt _ quoterName srcSpan str -> do
10391001 txt "["
10401002 p_rdrName (L srcSpan quoterName)
10411003 txt "|"
1042− -- QuasiQuoters often rely on precise custom strings. We cannot do any
1043− -- formatting here without potentially breaking someone's code.
1004+ -- NOTE QuasiQuoters often rely on precise custom strings. We cannot do
1005+ -- any formatting here without potentially breaking someone's code.
10441006 atom str
10451007 txt "|]"
10461008 HsSpliced {} -> notImplemented "HsSpliced"
10471009 HsSplicedT {} -> notImplemented "HsSplicedT"
1048− XSplice x -> noExtCon x
1010+ XSplice {} -> notImplemented "XSplice"
10491011
10501012p_hsSpliceTH ::
10511013 -- | Typed splice?
@@ -1069,17 +1031,17 @@ p_hsSpliceTH isTyped expr = \case
10691031
10701032p_hsBracket :: HsBracket GhcPs -> R ()
10711033p_hsBracket = \case
1072− ExpBr NoExtField expr -> do
1034+ ExpBr NoExt expr -> do
10731035 anns <- getEnclosingAnns
10741036 let name = case anns of
10751037 AnnOpenEQ : _ -> ""
10761038 _ -> "e"
10771039 quote name (located expr p_hsExpr)
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
1040+ PatBr NoExt pat -> quote "p" (p_pat pat)
1041+ DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
1042+ DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
1043+ TypBr NoExt ty -> quote "t" (located ty p_hsType)
1044+ VarBr NoExt isSingleQuote name -> do
10831045 txt (bool "''" "'" isSingleQuote)
10841046 -- HACK As you can see we use 'noLoc' here to be able to pass name into
10851047 -- 'p_rdrName' since the latter expects a "located" thing. The problem
@@ -1094,13 +1056,13 @@ p_hsBracket = \case
10941056 && not (doesNotNeedExtraParens name)
10951057 wrapper = if isOperator then parens N else id
10961058 wrapper $ p_rdrName (noLoc name)
1097− TExpBr NoExtField expr -> do
1059+ TExpBr NoExt expr -> do
10981060 txt "[||"
10991061 breakpoint'
11001062 located expr p_hsExpr
11011063 breakpoint'
11021064 txt "||]"
1103− XBracket x -> noExtCon x
1065+ XBracket {} -> notImplemented "XBracket"
11041066 where
11051067 quote :: Text -> R () -> R ()
11061068 quote name body = do
@@ -1179,9 +1141,9 @@ liftAppend (x : xs) [] = x : xs
11791141liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
11801142
11811143getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
1182−getGRHSSpan (GRHS NoExtField guards body) =
1144+getGRHSSpan (GRHS NoExt guards body) =
11831145 combineSrcSpans' $ getLoc body :| map getLoc guards
1184−getGRHSSpan (XGRHS x) = noExtCon x
1146+getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
11851147
11861148-- | Place a thing that may have a hanging form. This function handles how
11871149-- to separate it from preceding expressions and whether to bump indentation
@@ -1202,77 +1164,82 @@ blockPlacement ::
12021164 (body -> Placement) ->
12031165 [LGRHS GhcPs (Located body)] ->
12041166 Placement
1205−blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
1167+blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
12061168blockPlacement _ _ = Normal
12071169
12081170-- | Check if given command has a hanging form.
12091171cmdPlacement :: HsCmd GhcPs -> Placement
12101172cmdPlacement = \case
1211− HsCmdLam NoExtField _ -> Hanging
1212− HsCmdCase NoExtField _ _ -> Hanging
1213− HsCmdDo NoExtField _ -> Hanging
1173+ HsCmdLam NoExt _ -> Hanging
1174+ HsCmdCase NoExt _ _ -> Hanging
1175+ HsCmdDo NoExt _ -> Hanging
12141176 _ -> Normal
12151177
12161178cmdTopPlacement :: HsCmdTop GhcPs -> Placement
12171179cmdTopPlacement = \case
1218− HsCmdTop NoExtField (L _ x) -> cmdPlacement x
1219− XCmdTop x -> noExtCon x
1180+ HsCmdTop NoExt (L _ x) -> cmdPlacement x
1181+ XCmdTop {} -> notImplemented "XCmdTop"
12201182
12211183-- | Check if given expression has a hanging form.
12221184exprPlacement :: HsExpr GhcPs -> Placement
12231185exprPlacement = \case
12241186 -- Only hang lambdas with single line parameter lists
1225− HsLam NoExtField mg -> case mg of
1226− MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
1187+ HsLam NoExt mg -> case mg of
1188+ MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
12271189 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
12281190 Hanging
12291191 _ -> 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
1192+ HsLamCase NoExt _ -> Hanging
1193+ HsCase NoExt _ _ -> Hanging
1194+ HsDo NoExt DoExpr _ -> Hanging
1195+ HsDo NoExt MDoExpr _ -> Hanging
1196+ RecordCon NoExt _ _ -> Hanging
1197+ -- If the rightmost expression in an operator chain is hanging, make the
1198+ -- whole block hanging; so that we can use the common @f = foo $ do@
1199+ -- style.
1200+ OpApp NoExt _ _ y -> exprPlacement (unLoc y)
1201+ -- Same thing for function applications (usually with -XBlockArguments)
1202+ HsApp NoExt _ y -> exprPlacement (unLoc y)
1203+ HsProc NoExt p _ ->
1204+ -- https://gitlab.haskell.org/ghc/ghc/issues/17330
1205+ let loc = case p of
1206+ XPat pat -> getLoc pat
1207+ _ -> error "exprPlacement: HsProc: Pat does not contain a location"
1208+ in -- Indentation breaks if pattern is longer than one line and left
1209+ -- hanging. Consequently, only apply hanging when it is safe.
1210+ if isOneLineSpan loc
1211+ then Hanging
1212+ else Normal
12451213 _ -> Normal
12461214
12471215withGuards :: [LGRHS GhcPs (Located body)] -> Bool
12481216withGuards = any (checkOne . unLoc)
12491217 where
12501218 checkOne :: GRHS GhcPs (Located body) -> Bool
1251− checkOne (GRHS NoExtField [] _) = False
1219+ checkOne (GRHS NoExt [] _) = False
12521220 checkOne _ = True
12531221
12541222exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1255−exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
1223+exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
12561224exprOpTree n = OpNode n
12571225
12581226getOpName :: HsExpr GhcPs -> Maybe RdrName
12591227getOpName = \case
1260− HsVar NoExtField (L _ a) -> Just a
1228+ HsVar NoExt (L _ a) -> Just a
12611229 _ -> Nothing
12621230
1263−getOpNameStr :: RdrName -> String
1264−getOpNameStr = occNameString . rdrNameOcc
1265−
12661231p_exprOpTree ::
1232+ -- | Can use special handling of dollar?
1233+ Bool ->
12671234 -- | Bracket style to use
12681235 BracketStyle ->
12691236 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12701237 R ()
1271−p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
1272−p_exprOpTree s (OpBranch x op y) = do
1273− -- If the beginning of the first argument and the second argument are on
1274− -- the same line, and the second argument has a hanging form, use hanging
1275− -- placement.
1238+p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1239+p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1240+ -- NOTE If the beginning of the first argument and the second argument
1241+ -- are on the same line, and the second argument has a hanging form, use
1242+ -- hanging placement.
12761243 let placement =
12771244 if isOneLineSpan
12781245 (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
@@ -1280,10 +1247,8 @@ p_exprOpTree s (OpBranch x op y) = do
12801247 OpNode (L _ n) -> exprPlacement n
12811248 _ -> Normal
12821249 else Normal
1283− -- Distinguish holes used in infix notation.
1284− -- eg. '1 _foo 2' and '1 `_foo` 2'
12851250 opWrapper = case unLoc op of
1286− HsUnboundVar NoExtField _ -> backticks
1251+ EWildPat NoExt -> backticks
12871252 _ -> id
12881253 layout <- getLayout
12891254 let ub = case layout of
@@ -1291,67 +1256,24 @@ p_exprOpTree s (OpBranch x op y) = do
12911256 MultiLine -> case placement of
12921257 Hanging -> useBraces
12931258 Normal -> dontUseBraces
1294− opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
1295− gotDollar = opNameStr == Just "$"
1296− gotColon = opNameStr == Just ":"
1297− gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
1298− lhs =
1299− switchLayout [opTreeLoc x] $
1300− p_exprOpTree s x
1301− p_op = located op (opWrapper . p_hsExpr)
1302− p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
1303− isSection = case (opTreeLoc x, getLoc op) of
1304− (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
1305− srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
1306− _ -> False
1307− isDoBlock = \case
1308− OpNode (L _ HsDo {}) -> True
1259+ gotDollar = case getOpName (unLoc op) of
1260+ Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
13091261 _ -> False
1310− useRecordDot' <- useRecordDot
1311− if
1312− | gotColon -> do
1313− lhs
1314− space
1315− p_op
1316− case placement of
1317− Hanging -> do
1318− space
1319− p_y
1320− Normal -> do
1321− breakpoint
1322− inciIf (isDoBlock y) p_y
1323− | gotDollar
1324− && isOneLineSpan (opTreeLoc x)
1325− && placement == Normal -> do
1326− useBraces lhs
1327− space
1328− p_op
1329− breakpoint
1330− inci p_y
1331− | useRecordDot' && gotRecordDot -> do
1332− lhs
1333− when isSection space
1334− p_op
1335− p_y
1336− | otherwise -> do
1337− ub lhs
1338− placeHanging placement $ do
1339− p_op
1340− space
1341− p_y
1342−
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
1262+ switchLayout [opTreeLoc x]
1263+ $ ub
1264+ $ p_exprOpTree (not gotDollar) s x
1265+ let p_op = located op (opWrapper . p_hsExpr)
1266+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
1267+ if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
1268+ then do
1269+ space
1270+ p_op
1271+ breakpoint
1272+ inci p_y
1273+ else placeHanging placement $ do
1274+ p_op
1275+ space
1276+ p_y
13551277
13561278-- | Get annotations for the enclosing element.
13571279getEnclosingAnns :: R [AnnKeywordId]
src/Ormolu/Printer/Meat/Declaration/Value.hs-boot+4
@@ -11,7 +11,11 @@ import GHC
1111import Ormolu.Printer.Combinators
1212
1313p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
14+
1415p_pat :: Pat GhcPs -> R ()
16+
1517p_hsExpr :: HsExpr GhcPs -> R ()
18+
1619p_hsSplice :: HsSplice GhcPs -> R ()
20+
1721p_stringLit :: String -> R ()
src/Ormolu/Printer/Meat/Declaration/Warning.hs+10−8
@@ -13,28 +13,30 @@ import Data.Text (Text)
1313import GHC
1414import Ormolu.Printer.Combinators
1515import Ormolu.Printer.Meat.Common
16+import Ormolu.Utils
1617
1718p_warnDecls :: WarnDecls GhcPs -> R ()
18−p_warnDecls (Warnings NoExtField _ warnings) =
19+p_warnDecls (Warnings NoExt _ warnings) =
1920 traverse_ (located' p_warnDecl) warnings
20−p_warnDecls (XWarnDecls x) = noExtCon x
21+p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"
2122
2223p_warnDecl :: WarnDecl GhcPs -> R ()
23−p_warnDecl (Warning NoExtField functions warningTxt) =
24+p_warnDecl (Warning NoExt functions warningTxt) =
2425 p_topLevelWarning functions warningTxt
25−p_warnDecl (XWarnDecl x) = noExtCon x
26+p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"
2627
2728p_moduleWarning :: WarningTxt -> R ()
2829p_moduleWarning wtxt = do
2930 let (pragmaText, lits) = warningText wtxt
30− inci $ pragma pragmaText $ inci $ p_lits lits
31+ switchLayout (getLoc <$> lits) $ do
32+ inci $ pragma pragmaText (inci $ p_lits lits)
3133
3234p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
3335p_topLevelWarning fnames wtxt = do
3436 let (pragmaText, lits) = warningText wtxt
35− switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $
37+ switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $ do
3638 pragma pragmaText . inci $ do
37− sep commaDel p_rdrName fnames
39+ sitcc $ sep (comma >> breakpoint) p_rdrName fnames
3840 breakpoint
3941 p_lits lits
4042
@@ -46,4 +48,4 @@ warningText = \case
4648p_lits :: [Located StringLiteral] -> R ()
4749p_lits = \case
4850 [l] -> atom l
49− ls -> brackets N $ sep commaDel atom ls
51+ ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls
src/Ormolu/Printer/Meat/ImportExport.hs+36−45
@@ -11,9 +11,10 @@ where
1111
1212import Control.Monad
1313import GHC
14+import HsImpExp (IE (..))
1415import Ormolu.Printer.Combinators
1516import Ormolu.Printer.Meat.Common
16−import Ormolu.Utils (RelativePos (..), attachRelativePos)
17+import Ormolu.Utils
1718
1819p_hsmodExports :: [LIE GhcPs] -> R ()
1920p_hsmodExports [] = do
@@ -21,24 +22,19 @@ p_hsmodExports [] = do
2122 breakpoint'
2223 txt ")"
2324p_hsmodExports xs =
24− parens N $ do
25+ parens N . sitcc $ do
2526 layout <- getLayout
26− sep
27− breakpoint
28− (\(p, l) -> sitcc (located l (p_lie layout p)))
29− (attachRelativePos xs)
27+ sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
3028
31−p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()
32−p_hsmodImport useQualifiedPost ImportDecl {..} = do
29+p_hsmodImport :: ImportDecl GhcPs -> R ()
30+p_hsmodImport ImportDecl {..} = do
3331 txt "import"
3432 space
3533 when ideclSource (txt "{-# SOURCE #-}")
3634 space
3735 when ideclSafe (txt "safe")
3836 space
39− when
40− (isImportDeclQualified ideclQualified && not useQualifiedPost)
41− (txt "qualified")
37+ when ideclQualified (txt "qualified")
4238 space
4339 case ideclPkgQual of
4440 Nothing -> return ()
@@ -46,9 +42,6 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do
4642 space
4743 inci $ do
4844 located ideclName atom
49− when
50− (isImportDeclQualified ideclQualified && useQualifiedPost)
51− (space >> txt "qualified")
5245 case ideclAs of
5346 Nothing -> return ()
5447 Just l -> do
@@ -63,64 +56,62 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do
6356 when hiding (txt "hiding")
6457 case ideclHiding of
6558 Nothing -> return ()
66− Just (_, L _ xs) -> do
59+ Just (_, (L _ xs)) -> do
6760 breakpoint
68− parens N $ do
61+ parens N . sitcc $ do
6962 layout <- getLayout
70− sep
71− breakpoint
72− (\(p, l) -> sitcc (located l (p_lie layout p)))
73− (attachRelativePos xs)
63+ sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)
7464 newline
75−p_hsmodImport _ (XImportDecl x) = noExtCon x
65+p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"
7666
77−p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()
78−p_lie encLayout relativePos = \case
79− IEVar NoExtField l1 -> do
67+p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()
68+p_lie encLayout (i, totalItems) = \case
69+ IEVar NoExt l1 -> do
8070 located l1 p_ieWrappedName
8171 p_comma
82− IEThingAbs NoExtField l1 -> do
72+ IEThingAbs NoExt l1 -> do
8373 located l1 p_ieWrappedName
8474 p_comma
85− IEThingAll NoExtField l1 -> do
75+ IEThingAll NoExt l1 -> do
8676 located l1 p_ieWrappedName
8777 space
8878 txt "(..)"
8979 p_comma
90− IEThingWith NoExtField l1 w xs _ -> sitcc $ do
80+ IEThingWith NoExt l1 w xs _ -> sitcc $ do
9181 located l1 p_ieWrappedName
9282 breakpoint
9383 inci $ do
9484 let names :: [R ()]
9585 names = located' p_ieWrappedName <$> xs
96− parens N . sep commaDel sitcc $
97− case w of
86+ parens N . sitcc
87+ $ sep (comma >> breakpoint) sitcc
88+ $ case w of
9889 NoIEWildcard -> names
9990 IEWildcard n ->
10091 let (before, after) = splitAt n names
10192 in before ++ [txt ".."] ++ after
10293 p_comma
103− IEModuleContents NoExtField l1 -> do
94+ IEModuleContents NoExt l1 -> do
10495 located l1 p_hsmodName
10596 p_comma
106− IEGroup NoExtField n str -> do
107− case relativePos of
108− SinglePos -> return ()
109− FirstPos -> return ()
110− MiddlePos -> newline
111− LastPos -> newline
97+ IEGroup NoExt n str -> do
98+ unless (i == 0) newline
11299 p_hsDocString (Asterisk n) False (noLoc str)
113− IEDoc NoExtField str ->
100+ IEDoc NoExt str ->
114101 p_hsDocString Pipe False (noLoc str)
115− IEDocNamed NoExtField str -> p_hsDocName str
116− XIE x -> noExtCon x
102+ IEDocNamed NoExt str -> p_hsDocName str
103+ XIE NoExt -> notImplemented "XIE"
117104 where
118105 p_comma =
119106 case encLayout of
120− SingleLine ->
121− case relativePos of
122− SinglePos -> return ()
123− FirstPos -> comma
124− MiddlePos -> comma
125− LastPos -> return ()
107+ SingleLine -> unless (i + 1 == totalItems) comma
126108 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+15−35
@@ -9,12 +9,9 @@ module Ormolu.Printer.Meat.Module
99where
1010
1111import Control.Monad
12−import qualified Data.Text as T
1312import GHC
14−import Ormolu.Imports (normalizeImports)
15−import Ormolu.Parser.CommentStream
13+import Ormolu.Imports
1614import Ormolu.Parser.Pragma
17−import Ormolu.Parser.Shebang
1815import Ormolu.Printer.Combinators
1916import Ormolu.Printer.Comments
2017import Ormolu.Printer.Meat.Common
@@ -23,31 +20,15 @@ import Ormolu.Printer.Meat.Declaration.Warning
2320import Ormolu.Printer.Meat.ImportExport
2421import Ormolu.Printer.Meat.Pragma
2522
26−-- | Render a module.
27−p_hsModule ::
28− -- | Stack header
29− Maybe (RealLocated Comment) ->
30− -- | Shebangs
31− [Shebang] ->
32− -- | Pragmas and the associated comments
33− [([RealLocated Comment], Pragma)] ->
34− -- | Whether to use postfix qualified imports
35− Bool ->
36− -- | AST to print
37− HsModule GhcPs ->
38− R ()
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) ->
44− located x $ \shebang -> do
45− txt (T.pack shebang)
46− newline
47− forM_ mstackHeader $ \(L spn comment) -> do
48− spitCommentNow spn comment
49− newline
50− newline
23+p_hsModule :: [Pragma] -> ParsedSource -> R ()
24+p_hsModule pragmas (L moduleSpan HsModule {..}) = do
25+ -- NOTE If span of exports in multiline, the whole thing is multiline.
26+ -- This is especially important because span of module itself always seems
27+ -- to have length zero, so it's not reliable for layout selection.
28+ let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports
29+ deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage
30+ spans' = exportSpans ++ deprecSpan ++ [moduleSpan]
31+ switchLayout spans' $ do
5132 p_pragmas pragmas
5233 newline
5334 case hsmodName of
@@ -56,20 +37,19 @@ p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do
5637 located hsmodName' $ \name -> do
5738 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
5839 p_hsmodName name
59− breakpoint
6040 forM_ hsmodDeprecMessage $ \w -> do
61− located' p_moduleWarning w
6241 breakpoint
42+ located' p_moduleWarning w
6343 case hsmodExports of
6444 Nothing -> return ()
65− Just l -> do
66− located l $ \exports -> do
67− inci (p_hsmodExports exports)
45+ Just hsmodExports' -> do
6846 breakpoint
47+ inci (p_hsmodExports (unLoc hsmodExports'))
48+ breakpoint
6949 txt "where"
7050 newline
7151 newline
72− forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
52+ forM_ (sortImports hsmodImports) (located' p_hsmodImport)
7353 newline
7454 switchLayout (getLoc <$> hsmodDecls) $ do
7555 p_hsDecls Free hsmodDecls
src/Ormolu/Printer/Meat/Pragma.hs+13−67
@@ -8,84 +8,30 @@ module Ormolu.Printer.Meat.Pragma
88 )
99where
1010
11−import Control.Monad
12−import Data.Char (isUpper)
13−import qualified Data.List as L
14−import Data.Maybe (listToMaybe)
11+import qualified Data.Set as S
1512import qualified Data.Text as T
16−import Ormolu.Parser.CommentStream
1713import Ormolu.Parser.Pragma (Pragma (..))
1814import Ormolu.Printer.Combinators
19−import Ormolu.Printer.Comments
20−import SrcLoc
2115
22−-- | Pragma classification.
23−data PragmaTy
24− = Language LanguagePragmaClass
25− | OptionsGHC
26− | OptionsHaddock
16+data PragmaTy = Language | OptionsGHC | OptionsHaddock
2717 deriving (Eq, Ord)
2818
29−-- | Language pragma classification.
30−--
31−-- The order in which language pragmas are put in the input sometimes
32−-- matters. This is because some language extensions can enable other
33−-- extensions, yet the extensions coming later in the list have the ability
34−-- to change it. So here we classify all extensions by assigning one of the
35−-- four groups to them. Then we only sort inside of the groups.
36−--
37−-- 'Ord' instance of this data type is what affects the sorting.
38−--
39−-- See also: <https://github.com/tweag/ormolu/issues/404>
40−data LanguagePragmaClass
41− = -- | All other extensions
42− Normal
43− | -- | Extensions starting with "No"
44− Disabling
45− | -- | Extensions that should go after everything else
46− Final
47− deriving (Eq, Ord)
48−
49−-- | Print a collection of 'Pragma's with their associated comments.
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))
56− in f <$> xs
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
19+p_pragmas :: [Pragma] -> R ()
20+p_pragmas ps =
21+ let prepare = concatMap $ \case
22+ PragmaLanguage xs -> (Language,) <$> xs
23+ PragmaOptionsGHC x -> [(OptionsGHC, x)]
24+ PragmaOptionsHaddock x -> [(OptionsHaddock, x)]
25+ in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)
6126
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
27+p_pragma :: PragmaTy -> String -> R ()
28+p_pragma ty c = do
6729 txt "{-# "
6830 txt $ case ty of
69− Language _ -> "LANGUAGE"
31+ Language -> "LANGUAGE"
7032 OptionsGHC -> "OPTIONS_GHC"
7133 OptionsHaddock -> "OPTIONS_HADDOCK"
7234 space
73− txt (T.pack x)
35+ txt (T.pack c)
7436 txt " #-}"
7537 newline
76−
77−-- | Classify a 'LanguagePragma'.
78−classifyLanguagePragma :: String -> LanguagePragmaClass
79−classifyLanguagePragma = \case
80− "ImplicitPrelude" -> Final
81− "CUSKs" -> Final
82− str ->
83− case splitAt 2 str of
84− ("No", rest) ->
85− case listToMaybe rest of
86− Nothing -> Normal
87− Just x ->
88− if isUpper x
89− then Disabling
90− else Normal
91− _ -> Normal
src/Ormolu/Printer/Meat/Type.hs+68−93
@@ -5,7 +5,6 @@
55-- | Rendering of types.
66module Ormolu.Printer.Meat.Type
77 ( p_hsType,
8− p_hsTypePostDoc,
98 hasDocStrings,
109 p_hsContext,
1110 p_hsTyVarBndr,
@@ -24,23 +23,15 @@ import Ormolu.Printer.Operators
2423import Ormolu.Utils
2524
2625p_hsType :: HsType GhcPs -> R ()
27−p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t
26+p_hsType t = p_hsType' (hasDocStrings t) t
2827
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
28+p_hsType' :: Bool -> HsType GhcPs -> R ()
29+p_hsType' multilineArgs = \case
30+ HsForAllTy NoExt bndrs t -> do
31+ p_forallBndrs p_hsTyVarBndr bndrs
4132 interArgBreak
42− p_hsTypeR (unLoc t)
43− HsQualTy NoExtField qs t -> do
33+ p_hsType' multilineArgs (unLoc t)
34+ HsQualTy NoExt qs t -> do
4435 located qs p_hsContext
4536 space
4637 txt "=>"
@@ -49,7 +40,7 @@ p_hsType' multilineArgs docStyle = \case
4940 HsQualTy {} -> p_hsTypeR (unLoc t)
5041 HsFunTy {} -> p_hsTypeR (unLoc t)
5142 _ -> located t p_hsTypeR
52− HsTyVar NoExtField p n -> do
43+ HsTyVar NoExt p n -> do
5344 case p of
5445 IsPromoted -> do
5546 txt "'"
@@ -58,20 +49,10 @@ p_hsType' multilineArgs docStyle = \case
5849 _ -> return ()
5950 NotPromoted -> return ()
6051 p_rdrName n
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
52+ HsAppTy NoExt f x -> sitcc $ do
53+ located f p_hsType
54+ breakpoint
55+ inci (located x p_hsType)
7556 HsAppKindTy _ ty kd -> sitcc $ do
7657 -- The first argument is the location of the "@..." part. Not 100% sure,
7758 -- but I think we can ignore it as long as we use 'located' on both the
@@ -81,7 +62,7 @@ p_hsType' multilineArgs docStyle = \case
8162 inci $ do
8263 txt "@"
8364 located kd p_hsType
84− HsFunTy NoExtField x y@(L _ y') -> do
65+ HsFunTy NoExt x y@(L _ y') -> do
8566 located x p_hsType
8667 space
8768 txt "->"
@@ -89,49 +70,43 @@ p_hsType' multilineArgs docStyle = \case
8970 case y' of
9071 HsFunTy {} -> p_hsTypeR y'
9172 _ -> located y p_hsTypeR
92− HsListTy NoExtField t ->
73+ HsListTy NoExt t ->
9374 located t (brackets N . p_hsType)
94− HsTupleTy NoExtField tsort xs ->
75+ HsTupleTy NoExt tsort xs ->
9576 let parens' =
9677 case tsort of
9778 HsUnboxedTuple -> parensHash N
9879 HsBoxedTuple -> parens N
9980 HsConstraintTuple -> parens N
10081 HsBoxedOrConstraintTuple -> parens N
101− in parens' $ sep commaDel (sitcc . located' p_hsType) xs
102− HsSumTy NoExtField xs ->
103− parensHash N $
82+ in parens' . sitcc $
83+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
84+ HsSumTy NoExt xs ->
85+ parensHash N . sitcc $
10486 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
105− HsOpTy NoExtField x op y ->
106− sitcc $
107− let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
108− in p_tyOpTree (reassociateOpTree Just opTree)
109− HsParTy NoExtField t ->
87+ HsOpTy NoExt x op y -> sitcc $ do
88+ let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
89+ in p_tyOpTree (reassociateOpTree Just opTree)
90+ HsParTy NoExt t ->
11091 parens N (located t p_hsType)
111− HsIParamTy NoExtField n t -> sitcc $ do
92+ HsIParamTy NoExt n t -> sitcc $ do
11293 located n atom
11394 space
11495 txt "::"
11596 breakpoint
11697 inci (located t p_hsType)
117− HsStarTy NoExtField _ -> txt "*"
118− HsKindSig NoExtField t k -> sitcc $ do
98+ HsStarTy NoExt _ -> txt "*"
99+ HsKindSig NoExt t k -> sitcc $ do
119100 located t p_hsType
120− space
101+ space -- FIXME
121102 txt "::"
122− breakpoint
103+ space
123104 inci (located k p_hsType)
124− HsSpliceTy NoExtField splice -> p_hsSplice splice
125− HsDocTy NoExtField t str ->
126− case docStyle of
127− PipeStyle -> do
128− p_hsDocString Pipe True str
129− located t p_hsType
130− CaretStyle -> do
131− located t p_hsType
132− newline
133− p_hsDocString Caret False str
134− HsBangTy NoExtField (HsSrcBang _ u s) t -> do
105+ HsSpliceTy NoExt splice -> p_hsSplice splice
106+ HsDocTy NoExt t str -> do
107+ p_hsDocString Pipe True str
108+ located t p_hsType
109+ HsBangTy NoExt (HsSrcBang _ u s) t -> do
135110 case u of
136111 SrcUnpack -> txt "{-# UNPACK #-}" >> space
137112 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
@@ -141,9 +116,9 @@ p_hsType' multilineArgs docStyle = \case
141116 SrcStrict -> txt "!"
142117 NoSrcStrict -> return ()
143118 located t p_hsType
144− HsRecTy NoExtField fields ->
119+ HsRecTy NoExt fields ->
145120 p_conDeclFields fields
146− HsExplicitListTy NoExtField p xs -> do
121+ HsExplicitListTy NoExt p xs -> do
147122 case p of
148123 IsPromoted -> txt "'"
149124 NotPromoted -> return ()
@@ -151,39 +126,39 @@ p_hsType' multilineArgs docStyle = \case
151126 -- If both this list itself and the first element is promoted,
152127 -- we need to put a space in between or it fails to parse.
153128 case (p, xs) of
154− (IsPromoted, L _ t : _) | isPromoted t -> space
129+ (IsPromoted, ((L _ t) : _)) | isPromoted t -> space
155130 _ -> return ()
156− sep commaDel (sitcc . located' p_hsType) xs
157− HsExplicitTupleTy NoExtField xs -> do
131+ sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
132+ HsExplicitTupleTy NoExt xs -> do
158133 txt "'"
159134 parens N $ do
160135 case xs of
161− L _ t : _ | isPromoted t -> space
136+ ((L _ t) : _) | isPromoted t -> space
162137 _ -> return ()
163− sep commaDel (located' p_hsType) xs
164− HsTyLit NoExtField t ->
138+ sep (comma >> breakpoint) (located' p_hsType) xs
139+ HsTyLit NoExt t ->
165140 case t of
166141 HsStrTy (SourceText s) _ -> p_stringLit s
167142 a -> atom a
168− HsWildCardTy NoExtField -> txt "_"
143+ HsWildCardTy NoExt -> txt "_"
169144 XHsType (NHsCoreTy t) -> atom t
170145 where
171146 isPromoted = \case
172147 HsTyVar _ IsPromoted _ -> True
173− HsExplicitTupleTy {} -> True
174− HsExplicitListTy {} -> True
148+ HsExplicitListTy _ _ _ -> True
149+ HsExplicitTupleTy _ _ -> True
175150 _ -> False
176151 interArgBreak =
177152 if multilineArgs
178153 then newline
179154 else breakpoint
180− p_hsTypeR = p_hsType' multilineArgs docStyle
155+ p_hsTypeR = p_hsType' multilineArgs
181156
182157-- | Return 'True' if at least one argument in 'HsType' has a doc string
183158-- attached to it.
184159hasDocStrings :: HsType GhcPs -> Bool
185160hasDocStrings = \case
186− HsDocTy {} -> True
161+ HsDocTy _ _ _ -> True
187162 HsFunTy _ (L _ x) (L _ y) -> hasDocStrings x || hasDocStrings y
188163 _ -> False
189164
@@ -191,61 +166,61 @@ p_hsContext :: HsContext GhcPs -> R ()
191166p_hsContext = \case
192167 [] -> txt "()"
193168 [x] -> located x p_hsType
194− xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs
169+ xs ->
170+ parens N . sitcc $
171+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
195172
196173p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()
197174p_hsTyVarBndr = \case
198− UserTyVar NoExtField x ->
175+ UserTyVar NoExt x ->
199176 p_rdrName x
200− KindedTyVar NoExtField l k -> parens N $ do
177+ KindedTyVar NoExt l k -> parens N $ do
201178 located l atom
202179 space
203180 txt "::"
204181 breakpoint
205182 inci (located k p_hsType)
206− XTyVarBndr x -> noExtCon x
183+ XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
207184
208185-- | Render several @forall@-ed variables.
209−p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
210−p_forallBndrs ForallInvis _ [] = txt "forall."
211−p_forallBndrs ForallVis _ [] = txt "forall ->"
212−p_forallBndrs vis p tyvars =
186+p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()
187+p_forallBndrs _ [] = return ()
188+p_forallBndrs p tyvars =
213189 switchLayout (getLoc <$> tyvars) $ do
214190 txt "forall"
215191 breakpoint
216192 inci $ do
217193 sitcc $ sep breakpoint (sitcc . located' p) tyvars
218− case vis of
219− ForallInvis -> txt "."
220− ForallVis -> space >> txt "->"
194+ txt "."
221195
222196p_conDeclFields :: [LConDeclField GhcPs] -> R ()
223197p_conDeclFields xs =
224− braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
198+ braces N . sitcc $
199+ sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
225200
226201p_conDeclField :: ConDeclField GhcPs -> R ()
227202p_conDeclField ConDeclField {..} = do
228203 mapM_ (p_hsDocString Pipe True) cd_fld_doc
229204 sitcc $
230205 sep
231− commaDel
206+ (comma >> breakpoint)
232207 (located' (p_rdrName . rdrNameFieldOcc))
233208 cd_fld_names
234209 space
235210 txt "::"
236211 breakpoint
237212 sitcc . inci $ p_hsType (unLoc cd_fld_type)
238−p_conDeclField (XConDeclField x) = noExtCon x
213+p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"
239214
240215tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
241−tyOpTree (L _ (HsOpTy NoExtField l op r)) =
216+tyOpTree (L _ (HsOpTy NoExt l op r)) =
242217 OpBranch (tyOpTree l) op (tyOpTree r)
243218tyOpTree n = OpNode n
244219
245220p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R ()
246221p_tyOpTree (OpNode n) = located n p_hsType
247222p_tyOpTree (OpBranch l op r) = do
248− switchLayout [opTreeLoc l] $
223+ switchLayout [opTreeLoc l] $ do
249224 p_tyOpTree l
250225 breakpoint
251226 inci . switchLayout [opTreeLoc r] $ do
@@ -259,17 +234,17 @@ p_tyOpTree (OpBranch l op r) = do
259234tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
260235tyVarsToTypes = \case
261236 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
262− XLHsQTyVars x -> noExtCon x
237+ XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
263238
264239tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
265240tyVarToType = \case
266− UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
267− KindedTyVar NoExtField tvar kind ->
241+ UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
242+ KindedTyVar NoExt tvar kind ->
268243 -- Note: we always add parentheses because for whatever reason GHC does
269244 -- not use HsParTy for left-hand sides of declarations. Please see
270245 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
271246 -- long as 'tyVarToType' does not get applied to right-hand sides of
272247 -- declarations.
273− HsParTy NoExtField . noLoc $
274− HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
275− XTyVarBndr x -> noExtCon x
248+ HsParTy NoExt $ noLoc $
249+ HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
250+ XTyVarBndr {} -> notImplemented "XTyVarBndr"
src/Ormolu/Printer/Operators.hs+62−57
@@ -10,14 +10,14 @@ module Ormolu.Printer.Operators
1010 )
1111where
1212
13+import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)
1314import Data.Function (on)
14−import qualified Data.List as L
15−import Data.Map.Strict (Map)
16−import qualified Data.Map.Strict as M
17−import Data.Maybe (fromMaybe, mapMaybe)
15+import Data.List
16+import Data.Maybe (fromMaybe)
1817import GHC
19−import OccName (occNameString)
20−import Ormolu.Utils (unSrcSpan)
18+import OccName (mkVarOcc)
19+import RdrName (mkRdrUnqual)
20+import SrcLoc (combineSrcSpans)
2121
2222-- | Intermediate representation of operator trees. It has two type
2323-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type
@@ -57,7 +57,7 @@ reassociateOpTree getOpName opTree =
5757reassociateOpTreeWith ::
5858 forall ty op.
5959 -- | Fixity map for operators
60− Map String Fixity ->
60+ [(RdrName, Fixity)] ->
6161 -- | How to get the name of an operator
6262 (op -> Maybe RdrName) ->
6363 -- | Original 'OpTree'
@@ -68,13 +68,13 @@ reassociateOpTreeWith fixityMap getOpName = go
6868 where
6969 fixityOf :: op -> Fixity
7070 fixityOf op = fromMaybe defaultFixity $ do
71− s <- occNameString . rdrNameOcc <$> getOpName op
72− M.lookup s fixityMap
71+ opName <- getOpName op
72+ lookup opName fixityMap
7373 -- Here, left branch is already associated and the root alongside with
7474 -- the right branch is right-associated. This function picks up one item
7575 -- from the right and inserts it correctly to the left.
7676 --
77− -- Also, we are using the 'compareFixity' function which tells if the
77+ -- Also, we are using the 'compareFixity' function which returns if the
7878 -- expression should associate to right.
7979 go :: OpTree ty op -> OpTree ty op
8080 -- base cases
@@ -94,16 +94,6 @@ reassociateOpTreeWith fixityMap getOpName = go
9494 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'
9595 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'
9696
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−
10797-- | Build a map of inferred 'Fixity's from an 'OpTree'.
10898buildFixityMap ::
10999 forall ty op.
@@ -112,26 +102,23 @@ buildFixityMap ::
112102 -- | Operator tree
113103 OpTree (Located ty) (Located op) ->
114104 -- | Fixity map
115− Map String Fixity
105+ [(RdrName, Fixity)]
116106buildFixityMap getOpName opTree =
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
107+ concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
108+ . zip [0 ..]
109+ . groupBy (doubleWithinEps 0.00001 `on` snd)
110+ . (overrides ++)
111+ . avgScores
123112 $ score opTree
124113 where
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)]
114+ -- Add a special case for ($), since it is pretty unlikely for someone
115+ -- to override it.
116+ overrides :: [(RdrName, Double)]
117+ overrides =
118+ [ (mkRdrUnqual $ mkVarOcc "$", -1)
119+ ]
120+ -- Assign scores to operators based on their location in the source.
121+ score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]
135122 score (OpNode _) = []
136123 score (OpBranch l o r) = fromMaybe (score r) $ do
137124 -- If we fail to get any of these, 'defaultFixity' will be used by
@@ -141,27 +128,39 @@ buildFixityMap getOpName opTree =
141128 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
142129 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
143130 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
144− opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
145− let s
146− | le < ob = AtBeginning oc
147− | oe < rb = AtEnd
148− | otherwise = InBetween
131+ opName <- getOpName (unLoc o)
132+ let s =
133+ if le < ob
134+ then-- if the operator is in the beginning of a line, assign
135+ -- a score relative to its column within range [0, 1).
136+ fromIntegral oc / fromIntegral (maxCol + 1)
137+ else-- if the operator is in the end of the line, assign the
138+ -- score 1.
139+
140+ if oe < rb
141+ then 1
142+ else 2 -- otherwise, assign a high score.
149143 return $ (opName, s) : score r
150− selectScores :: [(String, Score)] -> [(String, Score)]
151− selectScores =
152− L.sortOn snd
153− . mapMaybe
154− ( \case
155− [] -> Nothing
156− xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)
157− )
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'
144+ avgScores :: [(RdrName, Double)] -> [(RdrName, Double)]
145+ avgScores =
146+ sortOn snd
147+ . map (\xs@((n, _) : _) -> (n, avg $ map snd xs))
148+ . groupBy ((==) `on` fst)
149+ . sort
150+ avg :: [Double] -> Double
151+ avg i = sum i / fromIntegral (length i)
152+ -- The start column of the rightmost operator.
153+ maxCol = go opTree
154+ where
155+ go (OpNode (L _ _)) = 0
156+ go (OpBranch l (L o _) r) =
157+ maximum
158+ [ go l,
159+ maybe 0 srcSpanStartCol (unSrcSpan o),
160+ go r
161+ ]
162+ unSrcSpan (RealSrcSpan r) = Just r
163+ unSrcSpan (UnhelpfulSpan _) = Nothing
165164
166165----------------------------------------------------------------------------
167166-- Helpers
@@ -175,3 +174,9 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =
175174 OpBranch (OpNode l) lop (normalizeOpTree r)
176175normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =
177176 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))
177+
178+fixity :: Int -> FixityDirection -> Fixity
179+fixity = Fixity NoSourceText
180+
181+doubleWithinEps :: Double -> Double -> Double -> Bool
182+doubleWithinEps eps a b = abs (a - b) < eps
src/Ormolu/Printer/SpanStream.hs+1−1
@@ -36,7 +36,7 @@ mkSpanStream a =
3636 $ everything mappend (const mempty `ext2Q` queryLocated) a
3737 where
3838 queryLocated ::
39− (Data e0) =>
39+ (Data e0, Data e1) =>
4040 GenLocated e0 e1 ->
4141 DList RealSrcSpan
4242 queryLocated (L mspn _) =
src/Ormolu/Processing/Common.hsdeleted−27
@@ -1,27 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−-- | Common definitions for pre- and post- processing.
4−module Ormolu.Processing.Common
5− ( OrmoluState (..),
6− startDisabling,
7− endDisabling,
8− )
9−where
10−
11−import Data.String (IsString (..))
12−
13−-- | Ormolu state.
14−data OrmoluState
15− = -- | Enabled
16− OrmoluEnabled
17− | -- | Disabled
18− OrmoluDisabled
19− deriving (Eq, Show)
20−
21−-- | Marker for the beginning of the region where Ormolu should be disabled.
22−startDisabling :: IsString s => s
23−startDisabling = "{- ORMOLU_DISABLE_START"
24−
25−-- | Marker for the end of the region where Ormolu should be disabled.
26−endDisabling :: IsString s => s
27−endDisabling = "ORMOLU_DISABLE_END -}"
src/Ormolu/Processing/Cpp.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−-- | Support for CPP.
4−module Ormolu.Processing.Cpp
5− ( State (..),
6− processLine,
7− unmaskLine,
8− )
9−where
10−
11−import Control.Monad
12−import Data.Char (isSpace)
13−import qualified Data.List as L
14−import Data.Maybe (isJust)
15−import Data.String
16−import Data.Text (Text)
17−import qualified Data.Text as T
18−
19−-- | State of the CPP processor.
20−data State
21− = -- | Outside of CPP directives
22− Outside
23− | -- | In a conditional expression
24− InConditional
25− | -- | In a continuation (after @\\@)
26− InContinuation
27− deriving (Eq, Show)
28−
29−-- | Automatically mask the line when needed and update the 'State'.
30−processLine :: String -> State -> (String, State)
31−processLine line state
32− | for "define " = (masked, state')
33− | for "include " = (masked, state')
34− | for "undef " = (masked, state')
35− | for "ifdef " = (masked, InConditional)
36− | for "ifndef " = (masked, InConditional)
37− | for "if " = (masked, InConditional)
38− | for "else" = (masked, InConditional)
39− | for "elif" = (masked, InConditional)
40− | for "endif" = (masked, state')
41− | otherwise =
42− case state of
43− Outside -> (line, Outside)
44− InConditional -> (masked, InConditional)
45− InContinuation -> (masked, state')
46− where
47− for directive = isJust $ do
48− s <- dropWhile isSpace <$> L.stripPrefix "#" line
49− void (L.stripPrefix directive s)
50− masked = maskLine line
51− state' =
52− if "\\" `L.isSuffixOf` line
53− then InContinuation
54− else Outside
55−
56−-- | Mask the given line.
57−maskLine :: String -> String
58−maskLine x = maskPrefix ++ x
59−
60−-- | If the given line is masked, unmask it. Otherwise return the line
61−-- unchanged.
62−unmaskLine :: Text -> Text
63−unmaskLine x =
64− case T.stripPrefix maskPrefix (T.stripStart x) of
65− Nothing -> x
66− Just x' -> x'
67−
68−-- | Mask prefix for CPP.
69−maskPrefix :: IsString s => s
70−maskPrefix = "-- ORMOLU_CPP_MASK"
src/Ormolu/Processing/Postprocess.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ViewPatterns #-}
3−
4−-- | Postprocessing for the results of printing.
5−module Ormolu.Processing.Postprocess
6− ( postprocess,
7− )
8−where
9−
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−import Ormolu.Processing.Common
13−import qualified Ormolu.Processing.Cpp as Cpp
14−
15−-- | Postprocess output of the formatter.
16−postprocess ::
17− -- | Desired indentation level
18− Int ->
19− -- | Input to process
20− Text ->
21− Text
22−postprocess indent =
23− T.unlines
24− . fmap indentLine
25− . fmap Cpp.unmaskLine
26− . filter (not . magicComment)
27− . T.lines
28− where
29− magicComment (T.stripStart -> x) =
30− x == startDisabling || x == endDisabling
31− indentLine x = T.replicate indent " " <> x
src/Ormolu/Processing/Preprocess.hsdeleted−149
@@ -1,149 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE RecordWildCards #-}
4−
5−-- | Preprocessing for input source code.
6−module Ormolu.Processing.Preprocess
7− ( preprocess,
8− )
9−where
10−
11−import Control.Monad
12−import Data.Char (isSpace)
13−import qualified Data.List as L
14−import Data.Maybe (isJust, maybeToList)
15−import FastString
16−import Ormolu.Config (RegionDeltas (..))
17−import Ormolu.Parser.Shebang (isShebang)
18−import Ormolu.Processing.Common
19−import qualified Ormolu.Processing.Cpp as Cpp
20−import SrcLoc
21−
22−-- | Transform given input possibly returning comments extracted from it.
23−-- This handles LINE pragmas, CPP, shebangs, and the magic comments for
24−-- enabling\/disabling of Ormolu.
25−preprocess ::
26− -- | File name, just to use in the spans
27− FilePath ->
28− -- | Input to process
29− String ->
30− -- | Region deltas
31− RegionDeltas ->
32− -- | Literal prefix, pre-processed input, literal suffix, extra comments
33− (String, String, String, [Located String])
34−preprocess path input RegionDeltas {..} =
35− go 1 OrmoluEnabled Cpp.Outside id id regionLines
36− where
37− (prefixLines, otherLines) = splitAt regionPrefixLength (lines input)
38− (regionLines, suffixLines) =
39− let regionLength = length otherLines - regionSuffixLength
40− in splitAt regionLength otherLines
41− go !n ormoluState cppState inputSoFar csSoFar = \case
42− [] ->
43− let input' = unlines (inputSoFar [])
44− in ( unlines prefixLines,
45− case ormoluState of
46− OrmoluEnabled -> input'
47− OrmoluDisabled -> input' ++ endDisabling,
48− unlines suffixLines,
49− csSoFar []
50− )
51− (x : xs) ->
52− let (x', ormoluState', cppState', cs) =
53− processLine path n ormoluState cppState x
54− in go
55− (n + 1)
56− ormoluState'
57− cppState'
58− (inputSoFar . (x' :))
59− (csSoFar . (maybeToList cs ++))
60− xs
61−
62−-- | Transform a given line possibly returning a comment extracted from it.
63−processLine ::
64− -- | File name, just to use in the spans
65− FilePath ->
66− -- | Line number of this line
67− Int ->
68− -- | Whether Ormolu is currently enabled
69− OrmoluState ->
70− -- | CPP state
71− Cpp.State ->
72− -- | The actual line
73− String ->
74− -- | Adjusted line and possibly a comment extracted from it
75− (String, OrmoluState, Cpp.State, Maybe (Located String))
76−processLine path n ormoluState Cpp.Outside line
77− | "{-# LINE" `L.isPrefixOf` line =
78− let (pragma, res) = getPragma line
79− size = length pragma
80− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
81− in (res, ormoluState, Cpp.Outside, Just (L ss pragma))
82− | isOrmoluEnable line =
83− case ormoluState of
84− OrmoluEnabled ->
85− (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
86− OrmoluDisabled ->
87− (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
88− | isOrmoluDisable line =
89− case ormoluState of
90− OrmoluEnabled ->
91− (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing)
92− OrmoluDisabled ->
93− (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing)
94− | isShebang line =
95− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length line))
96− in ("", ormoluState, Cpp.Outside, Just (L ss line))
97− | otherwise =
98− let (line', cppState') = Cpp.processLine line Cpp.Outside
99− in (line', ormoluState, cppState', Nothing)
100− where
101− mkSrcLoc' = mkSrcLoc (mkFastString path) n
102−processLine _ _ ormoluState cppState line =
103− let (line', cppState') = Cpp.processLine line cppState
104− in (line', ormoluState, cppState', Nothing)
105−
106−-- | Take a line pragma and output its replacement (where line pragma is
107−-- replaced with spaces) and the contents of the pragma itself.
108−getPragma ::
109− -- | Pragma line to analyze
110− String ->
111− -- | Contents of the pragma and its replacement line
112− (String, String)
113−getPragma [] = error "Ormolu.Preprocess.getPragma: input must not be empty"
114−getPragma s@(x : xs)
115− | "#-}" `L.isPrefixOf` s = ("#-}", " " ++ drop 3 s)
116− | otherwise =
117− let (prag, remline) = getPragma xs
118− in (x : prag, ' ' : remline)
119−
120−-- | Canonical enable marker.
121−enableMarker :: String
122−enableMarker = "{- ORMOLU_ENABLE -}"
123−
124−-- | Canonical disable marker.
125−disableMarker :: String
126−disableMarker = "{- ORMOLU_DISABLE -}"
127−
128−-- | Return 'True' if the given string is an enabling marker.
129−isOrmoluEnable :: String -> Bool
130−isOrmoluEnable = magicComment "ORMOLU_ENABLE"
131−
132−-- | Return 'True' if the given string is a disabling marker.
133−isOrmoluDisable :: String -> Bool
134−isOrmoluDisable = magicComment "ORMOLU_DISABLE"
135−
136−-- | Construct a function for whitespace-insensitive matching of string.
137−magicComment ::
138− -- | What to expect
139− String ->
140− -- | String to test
141− String ->
142− -- | Whether or not the two strings watch
143− Bool
144−magicComment expected s0 = isJust $ do
145− let trim = dropWhile isSpace
146− s1 <- trim <$> L.stripPrefix "{-" (trim s0)
147− s2 <- trim <$> L.stripPrefix expected s1
148− s3 <- L.stripPrefix "-}" s2
149− guard (all isSpace s3)
src/Ormolu/Utils.hs+9−83
@@ -1,66 +1,41 @@
11{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ViewPatterns #-}
43
54-- | Random utilities used by the code.
65module Ormolu.Utils
7− ( RelativePos (..),
8− attachRelativePos,
9− combineSrcSpans',
6+ ( combineSrcSpans',
7+ isModule,
108 notImplemented,
119 showOutputable,
1210 splitDocString,
1311 typeArgToType,
14− unSrcSpan,
15− incSpanLine,
16− separatedByBlank,
17− separatedByBlankNE,
18− onTheSameLine,
19− removeIndentation,
2012 )
2113where
2214
23−import Data.Char (isSpace)
15+import Data.Data (Data, showConstr, toConstr)
2416import Data.List (dropWhileEnd)
2517import Data.List.NonEmpty (NonEmpty (..))
26−import qualified Data.List.NonEmpty as NE
27−import Data.Maybe (fromMaybe)
2818import Data.Text (Text)
2919import qualified Data.Text as T
3020import GHC
31−import GHC.DynFlags (baseDynFlags)
21+import HsDoc (HsDocString, unpackHDS)
3222import qualified Outputable as GHC
3323
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−
5324-- | Combine all source spans from the given list.
5425combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
5526combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
5627
28+-- | Return 'True' if given element of AST is module.
29+isModule :: Data a => a -> Bool
30+isModule x = showConstr (toConstr x) == "HsModule"
31+
5732-- | Placeholder for things that are not yet implemented.
5833notImplemented :: String -> a
5934notImplemented msg = error $ "not implemented yet: " ++ msg
6035
6136-- | Pretty-print an 'GHC.Outputable' thing.
6237showOutputable :: GHC.Outputable o => o -> String
63−showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
38+showOutputable = GHC.showSDocUnsafe . GHC.ppr
6439
6540-- | Split and normalize a doc string. The result is a list of lines that
6641-- make up the comment.
@@ -99,57 +74,8 @@ splitDocString docStr =
9974 then dropSpace <$> xs
10075 else xs
10176
102−-- | Get 'LHsType' out of 'LHsTypeArg'.
10377typeArgToType :: LHsTypeArg p -> LHsType p
10478typeArgToType = \case
10579 HsValArg tm -> tm
10680 HsTypeArg _ ty -> ty
10781 HsArgPar _ -> notImplemented "HsArgPar"
108−
109−-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
110−unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
111−unSrcSpan = \case
112− RealSrcSpan r -> Just r
113− UnhelpfulSpan _ -> Nothing
114−
115−-- | Increment line number in a 'SrcSpan'.
116−incSpanLine :: Int -> SrcSpan -> SrcSpan
117−incSpanLine i = \case
118− RealSrcSpan s ->
119− let start = realSrcSpanStart s
120− end = realSrcSpanEnd s
121− incLine x =
122− let file = srcLocFile x
123− line = srcLocLine x
124− col = srcLocCol x
125− in mkRealSrcLoc file (line + i) col
126− in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end))
127− UnhelpfulSpan x -> UnhelpfulSpan x
128−
129−-- | Do two declarations have a blank between them?
130−separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
131−separatedByBlank loc a b =
132− fromMaybe False $ do
133− endA <- srcSpanEndLine <$> unSrcSpan (loc a)
134− startB <- srcSpanStartLine <$> unSrcSpan (loc b)
135− pure (startB - endA >= 2)
136−
137−-- | Do two declaration groups have a blank between them?
138−separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
139−separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
140−
141−-- | Return 'True' if one span ends on the same line the second one starts.
142−onTheSameLine :: SrcSpan -> SrcSpan -> Bool
143−onTheSameLine a b =
144− isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))
145−
146−-- | Remove indentation from a given 'String'. Return the input with
147−-- indentation removed and the detected indentation level.
148−removeIndentation :: String -> (String, Int)
149−removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)
150− where
151− n = minimum (getIndent <$> xs)
152− getIndent y =
153− if all isSpace y
154− then 0
155− else length (takeWhile isSpace y)
tests/Ormolu/Parser/PragmaSpec.hs+1−1
@@ -4,7 +4,7 @@ import Ormolu.Parser.Pragma
44import Test.Hspec
55
66spec :: Spec
7−spec =
7+spec = do
88 describe "parsePragma" $ do
99 stdTest "{-# LANGUAGE Foo #-}" (Just (PragmaLanguage ["Foo"]))
1010 stdTest "{-# language Foo #-}" (Just (PragmaLanguage ["Foo"]))
tests/Ormolu/PrinterSpec.hs+10−7
@@ -1,6 +1,9 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−module Ormolu.PrinterSpec (spec) where
3+module Ormolu.PrinterSpec
4+ ( spec,
5+ )
6+where
47
58import Control.Exception
69import Control.Monad
@@ -12,7 +15,7 @@ import qualified Data.Text.IO as T
1215import Ormolu
1316import Path
1417import Path.IO
15−import qualified System.FilePath as F
18+import System.FilePath (addExtension, dropExtensions, splitExtensions)
1619import Test.Hspec
1720
1821spec :: Spec
@@ -50,19 +53,19 @@ locateExamples =
5053isInput :: Path Rel File -> Bool
5154isInput path =
5255 let s = fromRelFile path
53− (s', exts) = F.splitExtensions s
56+ (s', exts) = splitExtensions s
5457 in exts == ".hs" && not ("-out" `isSuffixOf` s')
5558
5659-- | For given path of input file return expected name of output.
5760deriveOutput :: Path Rel File -> IO (Path Rel File)
5861deriveOutput path =
5962 parseRelFile $
60− F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs"
63+ addExtension (dropExtensions (fromRelFile path) ++ "-out") "hs"
6164
6265-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.
6366-- It also prints multi-line snippets in a more readable form.
6467shouldMatch :: Bool -> Text -> Text -> Expectation
65−shouldMatch idempotenceTest actual expected =
68+shouldMatch idempotencyTest actual expected =
6669 when (actual /= expected) . expectationFailure $
6770 unlines
6871 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",
@@ -72,8 +75,8 @@ shouldMatch idempotenceTest actual expected =
7275 ]
7376 where
7477 pass =
75− if idempotenceTest
76− then "idempotence pass"
78+ if idempotencyTest
79+ then "idempotency pass"
7780 else "first pass"
7881
7982examplesDir :: Path Rel Dir