git.iko.soy/ormolu
on d02483a help sign in
dec158c
swap
0 ahead, 148 behind
379 files changed+2268−5607
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−231 CONTRIBUTING.md+1−1 DESIGN.md+11−11 README.md+14−62 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−10 data/examples/declaration/class/type-operators3.hs−7 data/examples/declaration/data/existential-multiline-out.hs−12 data/examples/declaration/data/existential-multiline.hs−7 data/examples/declaration/data/existential-out.hs−2 data/examples/declaration/data/existential.hs−2 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/gadt/strictness-out.hs+1−2 data/examples/declaration/data/gadt/strictness.hs+1−2 data/examples/declaration/data/kind-annotations-out.hs−8 data/examples/declaration/data/kind-annotations.hs−7 data/examples/declaration/data/multiline-arg-parens-out.hs+1−1 data/examples/declaration/data/operators-out.hs−12 data/examples/declaration/data/operators.hs−12 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/strictness-out.hs+1−3 data/examples/declaration/data/strictness.hs+1−3 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/foreign/foreign-export-out.hs+1−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/rewrite-rule/basic1-out.hs+1−2 data/examples/declaration/rewrite-rule/forall-1-out.hs−23 data/examples/declaration/rewrite-rule/forall-1.hs−17 data/examples/declaration/rewrite-rule/forall-0-out.hs → data/examples/declaration/rewrite-rule/forall-out.hs data/examples/declaration/rewrite-rule/forall-0.hs → data/examples/declaration/rewrite-rule/forall.hs data/examples/declaration/rewrite-rule/phase-out.hs+2−4 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/long-multiline-applications-out.hs−1 data/examples/declaration/signature/type/long-multiline-applications.hs+1−2 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-families/closed-type-family/with-equal-sign-out.hs−2 data/examples/declaration/type-families/closed-type-family/with-equal-sign.hs−2 data/examples/declaration/type-families/closed-type-family/with-forall-out.hs−3 data/examples/declaration/type-families/closed-type-family/with-forall.hs−3 data/examples/declaration/type-families/type-family/operator-out.hs−3 data/examples/declaration/type-families/type-family/operator.hs−2 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/type-applications-out.hs−3 data/examples/declaration/type/type-applications.hs−3 data/examples/declaration/type/visible-forall-out.hs−2 data/examples/declaration/type/visible-forall.hs−2 data/examples/declaration/value/function/application-0-out.hs−17 data/examples/declaration/value/function/application-0.hs−12 data/examples/declaration/value/function/application-1-out.hs−19 data/examples/declaration/value/function/application-1.hs−14 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−7 data/examples/declaration/value/function/block-arguments.hs−7 data/examples/declaration/value/function/do/blocks-out.hs−1 data/examples/declaration/value/function/do/comment-alignment-out.hs−9 data/examples/declaration/value/function/do/comment-alignment.hs−9 data/examples/declaration/value/function/do/comment-spacing-out.hs−7 data/examples/declaration/value/function/do/comment-spacing.hs−7 data/examples/declaration/value/function/do/recursive-do-rec-out.hs−5 data/examples/declaration/value/function/if-with-comment-out.hs−8 data/examples/declaration/value/function/if-with-comment.hs−8 data/examples/declaration/value/function/implicit-params-out.hs−1 data/examples/declaration/value/function/implicit-params.hs−2 data/examples/declaration/value/function/infix/dollar-chains-out.hs+3−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/parens-out.hs−1 data/examples/declaration/value/function/parens.hs−1 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/static-pointers-out.hs+1−2 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−8 data/examples/module-header/preceding-comment-with-haddock.hs−8 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/haddock-sections-out.hs−7 data/examples/other/haddock-sections.hs−7 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−58 data/examples/other/multiline-forall.hs−46 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+44−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−12 src/GHC/DynFlags.hs−49 src/Ormolu.hs+19−19 src/Ormolu/Config.hs+29−65 src/Ormolu/Diff.hs+18−25 src/Ormolu/Exception.hs+20−27 src/Ormolu/Imports.hs+51−172 src/Ormolu/Parser.hs+117−135 src/Ormolu/Parser/CommentStream.hs+65−154 src/Ormolu/Parser/Pragma.hs+11−14 src/Ormolu/Parser/Result.hs+11−26 src/Ormolu/Parser/Shebang.hs−27 src/Ormolu/Printer.hs+6−17 src/Ormolu/Printer/Combinators.hs+30−41 src/Ormolu/Printer/Comments.hs+78−69 src/Ormolu/Printer/Internal.hs+110−173 src/Ormolu/Printer/Meat/Common.hs+22−25 src/Ormolu/Printer/Meat/Declaration.hs+111−176 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+58−74 src/Ormolu/Printer/Meat/Declaration/Default.hs+5−4 src/Ormolu/Printer/Meat/Declaration/Foreign.hs+7−9 src/Ormolu/Printer/Meat/Declaration/Instance.hs+28−22 src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+6−2 src/Ormolu/Printer/Meat/Declaration/Rule.hs+23−22 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+9−9 src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+37−42 src/Ormolu/Printer/Meat/Declaration/Value.hs+342−453 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+17−38 src/Ormolu/Printer/Meat/Pragma.hs+13−67 src/Ormolu/Printer/Meat/Type.hs+81−123 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+10−91 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−231
@@ -1,234 +1,3 @@
1−## Unreleased
2−
3−* Ormolu no longer overwrites already formatted files. [PR
4− 649](https://github.com/tweag/ormolu/pull/649).
5−
6−## Ormolu 0.1.2.0
7−
8−* Fixed the bug when comments in different styles got glued together after
9− formatting. [Issue 589](https://github.com/tweag/ormolu/issues/589).
10−
11−* Added `-i` as a shortcut for `--mode inplace`. [Issue
12− 467](https://github.com/tweag/ormolu/issues/467).
13−
14−* Improved grouping of top-level declarations. [Issue
15− 466](https://github.com/tweag/ormolu/issues/466).
16−
17−## Ormolu 0.1.1.0
18−
19−* Imports in a import lists are now normalized: duplicate imports are
20− combined/eliminated intelligently.
21−
22−* Import declarations that can be merged are now automatically merged.
23− [Issue 414](https://github.com/tweag/ormolu/issues/414).
24−
25−* The magic comments for disabling and enabling Ormolu now can encompass any
26− fragment of code provided that the remaining code after exclusion of the
27− disabled part is still syntactically correct. [Issue
28− 601](https://github.com/tweag/ormolu/issues/601).
29−
30−* Improved sorting of operators in imports. [Issue
31− 602](https://github.com/tweag/ormolu/issues/602).
32−
33−* Fixed a bug related to trailing space in multiline comments in certain
34− cases. [Issue 603](https://github.com/tweag/ormolu/issues/602).
35−
36−* Added support for formatting linked lists with `(:)` as line terminator.
37− [Issue 478](https://github.com/tweag/ormolu/issues/478).
38−
39−* Fixed rendering of function arguments in multiline layout. [Issue
40− 609](https://github.com/tweag/ormolu/issues/609).
41−
42−* Blank lines between definitions in `let` and `while` bindings are now
43− preserved. [Issue 554](https://github.com/tweag/ormolu/issues/554).
44−
45−* Fixed the bug when type applications stuck to the `$` of TH splices that
46− followed them. [Issue 613](https://github.com/tweag/ormolu/issues/613).
47−
48−* Improved region formatting so that indented fragments—such as definitions
49− inside of `where` clauses—can be formatted. [Issue
50− 572](https://github.com/tweag/ormolu/issues/572).
51−
52−* Fixed the bug related to the de-association of pragma comments. [Issue
53− 619](https://github.com/tweag/ormolu/issues/619).
54−
55−## Ormolu 0.1.0.0
56−
57−* Fixed rendering of type signatures concerning several identifiers. [Issue
58− 566](https://github.com/tweag/ormolu/issues/566).
59−
60−* Fixed an idempotence issue with inline comments in tuples and parentheses.
61− [Issue 450](https://github.com/tweag/ormolu/issues/450).
62−
63−* Fixed an idempotence issue when certain comments were picked up as
64− “continuation” of a series of comments [Issue
65− 449](https://github.com/tweag/ormolu/issues/449).
66−
67−* Fixed an idempotence issue related to different indentation levels in a
68− comment series. [Issue 512](https://github.com/tweag/ormolu/issues/512).
69−
70−* Fixed an idempotence issue related to comments which may happen to be
71− separated from the elements they are attached to by the equality sign.
72− [Issue 340](https://github.com/tweag/ormolu/issues/340).
73−
74−* Fixed an idempotence issue with type synonym and data declarations where
75− the type has a Haddock. [Issue
76− 578](https://github.com/tweag/ormolu/issues/578).
77−
78−* Fix the false positive about AST differences in presence of comments with
79− multiple blank lines in a row. [Issue
80− 518](https://github.com/tweag/ormolu/issues/518).
81−
82−* Fixed rendering of comments around if expressions. [Issue
83− 458](https://github.com/tweag/ormolu/issues/458).
84−
85−* Unnamed fields of data constructors are now documented using the `-- ^`
86− syntax. [Issue 445](https://github.com/tweag/ormolu/issues/445) and [Issue
87− 428](https://github.com/tweag/ormolu/issues/428).
88−
89−* Fixed non-idempotent transformation of partly documented data definition.
90− [Issue 590](https://github.com/tweag/ormolu/issues/590).
91−
92−* Fixed an idempotence issue related to operators. [Issue
93− 522](https://github.com/tweag/ormolu/issues/522).
94−
95−* Renamed the `--check-idempotency` flag to `--check-idempotence`.
96− Apparently only the latter is correct.
97−
98−## Ormolu 0.0.5.0
99−
100−* Grouping of statements in `do`-blocks is now preserved. [Issue
101− 74](https://github.com/tweag/ormolu/issues/74).
102−
103−* Grouping of TH splices is now preserved. [Issue
104− 507](https://github.com/tweag/ormolu/issues/507).
105−
106−* Comments on pragmas are now preserved. [Issue
107− 216](https://github.com/tweag/ormolu/issues/216).
108−
109−* Ormolu can now be enabled and disabled via special comments. [Issue
110− 435](https://github.com/tweag/ormolu/issues/435).
111−
112−* Added experimental support for simple CPP. [Issue
113− 415](https://github.com/tweag/ormolu/issues/415).
114−
115−* Added two new options `--start-line` and `--end-line` that allow us to
116− select a region to format. [Issue
117− 516](https://github.com/tweag/ormolu/issues/516).
118−
119−* Fixed rendering of module headers in the presence of preceding comments or
120− Haddocks. [Issue 561](https://github.com/tweag/ormolu/issues/561).
121−
122−## Ormolu 0.0.4.0
123−
124−* When given several files to format, Ormolu does not stop on the first
125− failure, but tries to format all the files. [Issue
126− 502](https://github.com/tweag/ormolu/issues/502).
127−
128−* Made rendering of pattern matches involving operators consistent with
129− other cases of rendering of operators. [Issue
130− 500](https://github.com/tweag/ormolu/issues/500).
131−
132−* More compact rendering of type family injectivity constraints. [Issue
133− 482](https://github.com/tweag/ormolu/issues/482).
134−
135−* Improved rendering of the keyword `where` in class, data, and type family
136− declarations. When headers of these declarations are multi-line `where` is
137− now put on its own line. [Issue
138− 509](https://github.com/tweag/ormolu/issues/509).
139−
140−* Fixed the bug pertaining to rendering of arrow notation with multiline
141− expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513).
142−
143−* Made rendering of data type definitions, value-level applications, and
144− application of types use the same style. Moreover, existential now doesn't
145− cause the data constructor be unconditionally rendered in multiline
146− layout. [Issue 427](https://github.com/tweag/ormolu/issues/427).
147−
148−* Records with a single data constructor are now formatted more compactly.
149− [Issue 425](https://github.com/tweag/ormolu/issues/425).
150−
151−* Switched to `ghc-lib-parser-8.10.1`.
152−
153−* Implemented support for the new language extensions `ImportQualifiedPost`
154− and `StandaloneKindSignatures`.
155−
156−## Ormolu 0.0.3.1
157−
158−* Fixed rendering of record updates with the record dot preprocessor syntax
159− [Issue 498](https://github.com/tweag/ormolu/issues/498).
160−
161−## Ormolu 0.0.3.0
162−
163−* Fixed an issue related to unnecessary use of curly braces. [Issue
164− 473](https://github.com/tweag/ormolu/issues/473).
165−
166−* Fixed the issue with formatting multi-way if when it happens to be a
167− function applied to arguments [Issue
168− 488](https://github.com/tweag/ormolu/issues/488). This changed the way
169− multi-line if is formatted in general.
170−
171−* Added support for record dot pre-processor when used via the plugin.
172− [Issue 486](https://github.com/tweag/ormolu/issues/486).
173−
174−* Stopped hanging record constructors and improved placing
175− potentially-hanging consturctions in the presence of comments. [Issue
176− 447](https://github.com/tweag/ormolu/issues/447).
177−
178−* Fixed indentation in presence of type applications. [Issue
179− 493](https://github.com/tweag/ormolu/issues/493).
180−
181−* Class and instance declarations now do not have a blank line after
182− `where`. Grouping of methods from the original input is also preserved
183− with some normalizations. [Issue
184− 431](https://github.com/tweag/ormolu/issues/431).
185−
186−## Ormolu 0.0.2.0
187−
188−* Switched to `ghc-lib-parser` instead of depending on the `ghc` package
189− directly. This should allow us to use newest features of GHC while not
190− necessarily depending on the newest version of the compiler. In addition
191− to that Ormolu is now GHCJS-compatible.
192−
193−* Now unrecognized GHC options passed with `--ghc-opt` cause Ormolu to fail
194− (exit code 7).
195−
196−* Fixed formatting of result type in closed type families. See [issue
197− 420](https://github.com/tweag/ormolu/issues/420).
198−
199−* Fixed a minor inconsistency between formatting of normal and foreign type
200− signatures. See [issue 408](https://github.com/tweag/ormolu/issues/408).
201−
202−* Fixed a bug when comment before module header with Haddock was moved
203− inside the export list. See [issue
204− 430](https://github.com/tweag/ormolu/issues/430).
205−
206−* Empty `forall`s are now correctly preserved. See [issue
207− 429](https://github.com/tweag/ormolu/issues/429).
208−
209−* Fixed [issue 446](https://github.com/tweag/ormolu/issues/446), which
210− involved braces and operators.
211−
212−* When there are comments between preceding Haddock (pipe-style) and its
213− corresponding declaration they are preserved like this in the output
214− instead of being shifted. To be clear, this is not a very good idea to
215− have comments in that position because the Haddock will end up not being
216− associated with the declarations. Issues
217− [440](https://github.com/tweag/ormolu/issues/440) and
218− [448](https://github.com/tweag/ormolu/issues/448).
219−
220−* Implemented correct handling of shebangs. [Issue
221− 377](https://github.com/tweag/ormolu/issues/377).
222−
223−* Implemented correct handling of stack headers. [Issue
224− 393](https://github.com/tweag/ormolu/issues/393).
225−
226−* Sorting language pragmas cannot not change meaning of the input program
227− anymore. [Issue 404](https://github.com/tweag/ormolu/issues/404).
228−
229−* Fixed formatting of applications where function is a complex expression.
230− [Issue 444](https://github.com/tweag/ormolu/issues/444).
231−
2321## Ormolu 0.0.1.0
2332
2343* 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+14−62
@@ -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,19 @@ 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+* [For Emacs][emacs-package]
106+
133107## Running on Hackage
134108
135109It's possible to try Ormolu on arbitrary packages from Hackage. For that
@@ -144,38 +118,16 @@ also contain formatted `.hs` files for inspection and original inputs with
144118`.hs-original` extension (those are with CPP dropped, exactly what is fed
145119into Ormolu).
146120
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−
163121## Contributing
164122
165−See [CONTRIBUTING.md][contributing].
123+See [CONTRIBUTING.md](./CONTRIBUTING.md).
166124
167125## License
168126
169−See [LICENSE.md][license].
127+See [LICENSE.md](./LICENSE.md).
170128
171129Copyright © 2018–present Tweag I/O
172130
173−[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp
174−[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md
175−[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md
131+[design]: ./DESIGN.md#cpp
176132[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts
177133[emacs-package]: https://github.com/vyorkin/ormolu.el
178−[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode
179−[vim-ormolu]: https://github.com/sdiehl/vim-ormolu
180−[neoformat]: https://github.com/sbdchd/neoformat
181−[aur]: https://aur.archlinux.org/packages/ormolu
app/Main.hs+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 " ++ VERSION_ghc
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.hsdeleted−10
@@ -1,10 +0,0 @@
1−{-# LANGUAGE PolyKinds #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE TypeOperators #-}
4−{-# LANGUAGE NoStarIsType #-}
5−
6−class PNum x where
7− type (a :: x) * (b :: x)
8−
9−instance PNum Nat where
10− type a * b = ()
data/examples/declaration/class/type-operators3.hsdeleted−7
@@ -1,7 +0,0 @@
1−{-# LANGUAGE TypeFamilies, TypeOperators, NoStarIsType, PolyKinds #-}
2−
3−class PNum x where
4− type (a :: x) * (b :: x)
5−
6−instance PNum Nat where
7− type a * b = ()
data/examples/declaration/data/existential-multiline-out.hs−12
@@ -3,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/existential-out.hs−2
@@ -1,5 +1,3 @@
11{-# LANGUAGE ExistentialQuantification #-}
22
33data Foo = forall a. MkFoo a (a -> Bool)
4−
5−data Bar = forall a b. a + b => Bar a b
data/examples/declaration/data/existential.hs−2
@@ -1,5 +1,3 @@
11{-# LANGUAGE ExistentialQuantification #-}
22
33data Foo = forall a. MkFoo a (a -> Bool)
4−
5−data Bar = forall a b. a + b => Bar a b
data/examples/declaration/data/field-layout/gadt-out.hs+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/gadt/strictness-out.hs+1−2
@@ -1,3 +1,2 @@
11data Foo a where
2− Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
3− Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int
2+ Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
data/examples/declaration/data/gadt/strictness.hs+1−2
@@ -1,3 +1,2 @@
11data Foo a where
2− Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
3− Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int
2+ Foo :: !Int -> {-# UNPACK #-} !Bool -> Foo Int
data/examples/declaration/data/kind-annotations-out.hs−8
@@ -1,11 +1,3 @@
11data Something (n :: Nat) = Something
22
33data Format (k :: *) (k' :: *) (k'' :: *)
4−
5−type Parens1 = Proxy '(a :: A, b :: (B :: *))
6−
7−type Parens2 = Proxy '((a :: A), (b :: B))
8−
9−type family Foo a where
10− Foo '(a :: Int, b :: Bool) = Int
11− Foo '((a :: Int), (b :: Bool)) = Int
data/examples/declaration/data/kind-annotations.hs−7
@@ -1,10 +1,3 @@
11data Something (n :: Nat) = Something
22
33data Format (k :: *) (k' :: *) (k'' :: *)
4−
5−type Parens1 = Proxy '(a :: A, b :: (B :: *))
6−type Parens2 = Proxy '((a :: A), (b :: B))
7−
8−type family Foo a where
9− Foo '(a :: Int, b :: Bool) = Int
10− Foo '((a :: Int), (b :: Bool)) = Int
data/examples/declaration/data/multiline-arg-parens-out.hs+1−1
@@ -5,6 +5,6 @@ data Foo
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/operators-out.hsdeleted−12
@@ -1,12 +0,0 @@
1−data ErrorMessage' s
2− = -- | Show the text as is.
3− Text s
4− | -- | Pretty print the type.
5− -- @ShowType :: k -> ErrorMessage@
6− forall t. ShowType t
7− | -- | Put two pieces of error message next
8− -- to each other.
9− ErrorMessage' s :<>: ErrorMessage' s
10− | -- | Stack two pieces of error message on top
11− -- of each other.
12− ErrorMessage' s :$$: ErrorMessage' s
data/examples/declaration/data/operators.hsdeleted−12
@@ -1,12 +0,0 @@
1−data ErrorMessage' s
2− = -- | Show the text as is.
3− Text s
4− | -- | Pretty print the type.
5− -- @ShowType :: k -> ErrorMessage@
6− forall t. ShowType t
7− | -- | Put two pieces of error message next
8− -- to each other.
9− ErrorMessage' s :<>: ErrorMessage' s
10− | -- | Stack two pieces of error message on top
11− -- of each other.
12− ErrorMessage' s :$$: ErrorMessage' s
data/examples/declaration/data/partly-documented-out.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/strictness-out.hs+1−3
@@ -1,6 +1,4 @@
11module Main where
22
33-- | Something.
4−data Foo
5− = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
6− | Foo2 {a :: {-# UNPACK #-} Maybe Int && Bool}
4+data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
data/examples/declaration/data/strictness.hs+1−3
@@ -2,6 +2,4 @@ module Main where
22
33-- | Something.
44
5−data Foo
6− = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
7− | Foo2 { a :: {-# UNPACK #-} Maybe Int && Bool }
5+data Foo = Foo !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String
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/foreign/foreign-export-out.hs+1−2
@@ -2,8 +2,7 @@ foreign export ccall foo :: Int -> IO Int
22
33-- | 'foreignTomFun' is a very important thing
44foreign export ccall "tomography"
5− foreignTomFun ::
6− StablePtr Storage {- Storage is bad -} -> TomForegin
5+ foreignTomFun :: StablePtr Storage {- Storage is bad -} -> TomForegin
76
87foreign export {- We can't use capi here -} ccall "dynamic"
98 export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
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/rewrite-rule/basic1-out.hs+1−2
@@ -10,8 +10,7 @@
1010
1111{-# RULES
1212"map/map"
13− map
14− f
13+ map f
1514 (map g xs) =
1615 map
1716 (f . g)
data/examples/declaration/rewrite-rule/forall-1-out.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}
2−
3−{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}
4−
5−{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}
6−
7−{-# RULES
8−"rd_tyvs_multiline1" forall (a :: *). forall (x :: a).
9− id x =
10− x
11− #-}
12−
13−{-# RULES
14−"rd_tyvs_multiline2" forall
15− ( a ::
16− *
17− ). forall
18− ( x ::
19− a
20− ).
21− id x =
22− x
23− #-}
data/examples/declaration/rewrite-rule/forall-1.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-}
2−
3−{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-}
4−
5−{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-}
6−
7−{-# RULES "rd_tyvs_multiline1"
8− forall (a :: *).
9− forall (x :: a).
10− id x = x #-}
11−
12−{-# RULES "rd_tyvs_multiline2"
13− forall (a ::
14− *).
15− forall (x ::
16− a).
17− id x = x #-}
data/examples/declaration/rewrite-rule/forall-0-out.hs → data/examples/declaration/rewrite-rule/forall-out.hsrenamed

The content is the same.

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

The content is the same.

data/examples/declaration/rewrite-rule/phase-out.hs+2−4
@@ -1,7 +1,6 @@
11{-# RULES
22"map/map" [2]
3− map
4− f
3+ map f
54 (map g xs) =
65 map
76 (f . g)
@@ -10,8 +9,7 @@
109
1110{-# RULES
1211"map/map" [1] forall x y z.
13− map
14− f
12+ map f
1513 (map g xs) =
1614 map
1715 (f . g)
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/long-multiline-applications-out.hs−1
@@ -1,6 +1,5 @@
11functionName ::
22 (C1, C2, C3, C4, C5) =>
3− forall a b c.
43 a ->
54 b ->
65 ( LongDataTypeName
data/examples/declaration/signature/type/long-multiline-applications.hs+1−2
@@ -1,7 +1,6 @@
11functionName
22 :: (C1, C2, C3, C4, C5)
3− => forall a b c
4− . a
3+ => a
54 -> b
65 -> ( LongDataTypeName
76 AnotherLongDataTypeName
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-families/closed-type-family/with-equal-sign-out.hsdeleted−2
@@ -1,2 +0,0 @@
1−type family TF a b = result where
2− TF a b = Int
data/examples/declaration/type-families/closed-type-family/with-equal-sign.hsdeleted−2
@@ -1,2 +0,0 @@
1−type family TF a b = result where
2− TF a b = Int
data/examples/declaration/type-families/closed-type-family/with-forall-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−type family G a b where
2− forall x y. G [x] (Proxy y) = Double
3− forall z. z `G` z = Bool
data/examples/declaration/type-families/closed-type-family/with-forall.hsdeleted−3
@@ -1,3 +0,0 @@
1−type family G a b where
2− forall x y. G [x] (Proxy y) = Double
3− forall z. z `G` z = Bool
data/examples/declaration/type-families/type-family/operator-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−type family a ! b
2−
3−type family a . b
data/examples/declaration/type-families/type-family/operator.hsdeleted−2
@@ -1,2 +0,0 @@
1−type family a ! b
2−type family a . b
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/type-applications-out.hsdeleted−3
@@ -1,3 +0,0 @@
1−{-# LANGUAGE TypeApplications #-}
2−
3−type P = K @Bool @(Bool :: *) 'True 'False
data/examples/declaration/type/type-applications.hsdeleted−3
@@ -1,3 +0,0 @@
1−{-# LANGUAGE TypeApplications #-}
2−
3−type P = K @Bool @(Bool :: *) 'True 'False
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-0-out.hsdeleted−17
@@ -1,17 +0,0 @@
1−foo =
2− f1
3− p1
4− p2
5− p3
6−
7−foo' =
8− f2
9− p1
10− p2
11− p3
12−
13−foo'' =
14− f3
15− p1
16− p2
17− p3
data/examples/declaration/value/function/application-0.hsdeleted−12
@@ -1,12 +0,0 @@
1−foo =
2− f1
3− p1
4− p2 p3
5−
6−foo' = f2 p1
7− p2
8− p3
9−
10−foo'' =
11− f3 p1 p2
12− p3
data/examples/declaration/value/function/application-1-out.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/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−7
@@ -25,10 +25,3 @@ f7 = foo \x -> y
2525
2626f8 = foo \x ->
2727 y
28−
29−f9 = foo do { bar } baz
30−
31−f10 = foo
32− do a
33− do b
34− do c
data/examples/declaration/value/function/block-arguments.hs−7
@@ -21,10 +21,3 @@ f7 = foo \x -> y
2121
2222f8 = foo \x ->
2323 y
24−
25−f9 = foo do { bar } baz
26−
27−f10 = foo
28− do { a }
29− do { b }
30− do c
data/examples/declaration/value/function/do/blocks-out.hs−1
@@ -15,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/parens-out.hsdeleted−1
@@ -1 +0,0 @@
1−f = p (do foo; bar) baz
data/examples/declaration/value/function/parens.hsdeleted−1
@@ -1 +0,0 @@
1−f = p (do foo; bar) baz
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/static-pointers-out.hs+1−2
@@ -14,7 +14,6 @@ bar =
1414baz :: StaticPtr Bool
1515baz =
1616 static
17− ( fun
18− 1
17+ ( fun 1
1918 2
2019 )
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.hsdeleted−8
@@ -1,8 +0,0 @@
1−{-
2− Here we go.
3−-}
4−
5−-- | This is the module's Haddock.
6−module Main (main) where
7−
8−main = return ()
data/examples/module-header/preceding-comment-with-haddock.hsdeleted−8
@@ -1,8 +0,0 @@
1−{-
2− Here we go.
3−-}
4−
5−-- | This is the module's Haddock.
6−module Main (main) where
7−
8−main = return ()
data/examples/module-header/shebang-out.hs−1
@@ -1,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/haddock-sections-out.hsdeleted−7
@@ -1,7 +0,0 @@
1−-- $weird #anchor#
2−--
3−-- Section 1
4−
5−-- $normal
6−--
7−-- Section 2
data/examples/other/haddock-sections.hsdeleted−7
@@ -1,7 +0,0 @@
1−-- $weird #anchor#
2−--
3−-- Section 1
4−
5−-- $normal
6−--
7−-- Section 2
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.hsdeleted−58
@@ -1,58 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE TypeFamilies #-}
5−
6−-- Multiline foralls are consistent across all declarations
7−
8−data D
9− = forall
10− ( f ::
11− * -> * -> *
12− )
13− (x :: *)
14− (y :: *).
15− D (f x y)
16−
17−data G where
18− G ::
19− forall
20− ( f ::
21− * -> * -> *
22− )
23− (x :: *)
24− (y :: *).
25− f x y ->
26− G
27−
28−f ::
29− forall
30− ( f ::
31− * -> * -> *
32− )
33− (x :: *)
34− (y :: *).
35− f x y ->
36− ()
37−f = const ()
38−
39−type family T f x y where
40− forall
41− ( f ::
42− * -> * -> *
43− )
44− (x :: *)
45− (y :: *).
46− T f x y =
47− f x y
48−
49−{-# RULES
50−"r" forall
51− ( f ::
52− * -> * -> *
53− )
54− (x :: *)
55− (y :: *).
56− r (a :: f x y) =
57− ()
58− #-}
data/examples/other/multiline-forall.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE RankNTypes, PolyKinds, GADTs, TypeFamilies #-}
2−
3−-- Multiline foralls are consistent across all declarations
4−
5−data D =
6− forall
7− (f ::
8− * -> * -> *)
9− (x :: *)
10− (y :: *)
11− . D (f x y)
12−
13−data G where
14− G :: forall
15− (f ::
16− * -> * -> *)
17− (x :: *)
18− (y :: *)
19− . f x y -> G
20−
21−f :: forall
22− (f ::
23− * -> * -> *)
24− (x :: *)
25− (y :: *)
26− . f x y -> ()
27−f = const ()
28−
29−type family T f x y where
30− forall
31− (f ::
32− * -> * -> *)
33− (x :: *)
34− (y :: *)
35− . T f x y = f x y
36−
37−{-# RULES
38− "r"
39− forall
40− (f ::
41− * -> * -> *)
42− (x :: *)
43− (y :: *)
44− . r (a :: f x y) =
45− ()
46− #-}
data/examples/other/multiple-blank-line-comment-out.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+44−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,51 @@ let
1614 overrides = ormoluOverlay;
1715 };
1816 ormoluOverlay = self: super: {
19− "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };
17+ "ormolu" = super.callCabal2nix "ormolu" source { };
2018 };
2119 ormolize = import ./nix/ormolize {
2220 inherit pkgs;
2321 inherit haskellPackages;
2422 };
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"]);
23+ # NOTE We have to exclude some directories for some packages because
24+ # Ormolu needs files to be parsable by Haddock which is not always the
25+ # case. For example some tests and examples do not parse.
26+ excludedHackageDirs = {
27+ "aws" = ["Examples"];
28+ "distributed-process" = ["benchmarks"];
29+ "esqueleto" = ["test"];
30+ "fay" = ["examples"];
31+ "postgrest" = ["test"];
32+ };
4133 ormolizedPackages = doCheck:
4234 pkgs.lib.mapAttrs (name: p: ormolize {
4335 package = p;
4436 inherit doCheck;
45− expectedFailures =
46− if pkgs.lib.lists.any (x: x == name) expectedFailures
47− then ./expected-failures + "/${name}.txt"
48− else null;
37+ excludedDirs =
38+ if builtins.hasAttr name excludedHackageDirs
39+ then excludedHackageDirs.${name}
40+ else [];
4941 }) haskellPackages;
5042in {
5143 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− };
44+ ormoluShell = haskellPackages.shellFor {
45+ packages = ps: [
46+ ps.ormolu
47+ ];
48+ buildInputs = [
49+ haskellPackages.cabal-install
50+ haskellPackages.ghcid
51+ ];
7252 };
7353 inherit ormoluOverlay ormoluCompiler;
7454 hackage = ormolizedPackages false;
7555 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (
7656 let ps = [
77− "Agda"
7857 "QuickCheck"
7958 "ShellCheck"
8059 "aeson"
8160 "attoparsec"
8261 "aws"
83− "brick"
8462 "capability"
8563 "cassava"
8664 "conduit"
@@ -92,78 +70,36 @@ in {
9270 "hakyll"
9371 "haxl"
9472 "hedgehog"
95− "hledger"
9673 "hlint"
97− "http-client"
98− "idris"
99− "intero"
100− "leksah"
101− "lens"
10274 "megaparsec"
103− "optics"
10475 "ormolu"
105− "pandoc"
106− "parsec3"
107− "pipes"
10876 "postgrest"
109− "purescript"
11077 "servant"
11178 "servant-server"
112− "stack"
11379 "tensorflow"
11480 "text_1_2_4_0"
11581 "tls"
11682 "yesod-core"
83+
84+ # Comment idempotence issue
85+
86+ # "Agda"
87+ # "brick"
88+ # "hledger"
89+ # "http-client"
90+ # "idris"
91+ # "intero"
92+ # "leksah"
93+ # "pandoc"
94+ # "pipes"
95+ # "stack"
96+
97+ # Missing language extension
98+
99+ # "lens" #fixed in master
100+ # "purescript"
101+
117102 ];
118103 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)
119104 );
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− };
169105}
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 = "3f4144c30a6351dd79b177328ec4dea03e2ce45f";
3+ sha256 = "1qg5n60n3fr6cypihnrjw451fadps5pysj5p0vvfb320mpfvlbjb";
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 == 8.6.5
72+ , ghc-boot-th == 8.6.5
73+ , ghc-paths >= 0.1 && < 0.2
74+ , mtl >= 2.0 && < 3.0
75+ , syb >= 0.7 && < 0.8
76+ , text >= 0.2 && < 1.3
77+ exposed-modules: Ormolu
78+ , Ormolu.Config
79+ , Ormolu.Diff
80+ , Ormolu.Exception
81+ , Ormolu.Imports
82+ , Ormolu.Parser
83+ , Ormolu.Parser.Anns
84+ , Ormolu.Parser.CommentStream
85+ , Ormolu.Parser.Pragma
86+ , Ormolu.Parser.Result
87+ , Ormolu.Printer
88+ , Ormolu.Printer.Combinators
89+ , Ormolu.Printer.Comments
90+ , Ormolu.Printer.Internal
91+ , Ormolu.Printer.Meat.Common
92+ , Ormolu.Printer.Meat.Declaration
93+ , Ormolu.Printer.Meat.Declaration.Annotation
94+ , Ormolu.Printer.Meat.Declaration.Class
95+ , Ormolu.Printer.Meat.Declaration.Data
96+ , Ormolu.Printer.Meat.Declaration.Default
97+ , Ormolu.Printer.Meat.Declaration.Foreign
98+ , Ormolu.Printer.Meat.Declaration.Instance
99+ , Ormolu.Printer.Meat.Declaration.RoleAnnotation
100+ , Ormolu.Printer.Meat.Declaration.Rule
101+ , Ormolu.Printer.Meat.Declaration.Signature
102+ , Ormolu.Printer.Meat.Declaration.Splice
103+ , Ormolu.Printer.Meat.Declaration.Type
104+ , Ormolu.Printer.Meat.Declaration.TypeFamily
105+ , Ormolu.Printer.Meat.Declaration.Value
106+ , Ormolu.Printer.Meat.Declaration.Warning
107+ , Ormolu.Printer.Meat.ImportExport
108+ , Ormolu.Printer.Meat.Module
109+ , Ormolu.Printer.Meat.Pragma
110+ , Ormolu.Printer.Meat.Type
111+ , Ormolu.Printer.Operators
112+ , Ormolu.Printer.SpanStream
113+ , Ormolu.Utils
114+ if flag(dev)
115+ ghc-options: -Wall -Werror -Wcompat
116+ -Wincomplete-record-updates
117+ -Wincomplete-uni-patterns
118+ -Wnoncanonical-monad-instances
119+ -Wnoncanonical-monadfail-instances
120+ else
121+ ghc-options: -O2 -Wall
122+ default-language: Haskell2010
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 == 8.6.5
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.hsdeleted−12
@@ -1,12 +0,0 @@
1−module GHC
2− ( module X,
3− )
4−where
5−
6−import ApiAnnotation as X
7−import BasicTypes as X
8−import GHC.Hs as X
9−import GHC.Hs.Instances as X ()
10−import Module as X
11−import RdrName as X
12−import SrcLoc as X
src/GHC/DynFlags.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# OPTIONS_GHC -Wno-missing-fields #-}
2−
3−-- Modified from ghc-lib-api-ext.
4−
5−module GHC.DynFlags
6− ( baseDynFlags,
7− )
8−where
9−
10−import Config
11−import DynFlags
12−import Fingerprint
13−import GHC.Platform
14−import ToolSettings
15−
16−fakeSettings :: Settings
17−fakeSettings =
18− Settings
19− { sGhcNameVersion =
20− GhcNameVersion
21− { ghcNameVersion_programName = "ghc",
22− ghcNameVersion_projectVersion = cProjectVersion
23− },
24− sFileSettings = FileSettings {},
25− sTargetPlatform =
26− Platform
27− { platformWordSize = PW8,
28− platformMini =
29− PlatformMini
30− { platformMini_arch = ArchUnknown,
31− platformMini_os = OSUnknown
32− },
33− platformUnregisterised = True
34− },
35− sPlatformMisc = PlatformMisc {},
36− sPlatformConstants =
37− PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},
38− sToolSettings =
39− ToolSettings
40− { toolSettings_opt_P_fingerprint = fingerprint0,
41− toolSettings_pgm_F = ""
42− }
43− }
44−
45−fakeLlvmConfig :: LlvmConfig
46−fakeLlvmConfig = LlvmConfig [] []
47−
48−baseDynFlags :: DynFlags
49−baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
src/Ormolu.hs+19−19
@@ -1,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+18−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,16 +10,17 @@ 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
23+import qualified SrcLoc as GHC
2124
2225-- | Result of comparing two 'ParseResult's.
2326data Diff
@@ -39,16 +42,14 @@ diffParseResult :: ParseResult -> ParseResult -> Diff
3942diffParseResult
4043 ParseResult
4144 { prCommentStream = cstream0,
42− prParsedSource = hs0
45+ prParsedSource = ps0
4346 }
4447 ParseResult
4548 { prCommentStream = cstream1,
46− prParsedSource = hs1
49+ prParsedSource = ps1
4750 } =
4851 matchIgnoringSrcSpans cstream0 cstream1
49− <> matchIgnoringSrcSpans
50− hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}
51− hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}
52+ <> matchIgnoringSrcSpans ps0 ps1
5253
5354-- | Compare two values for equality disregarding differences in 'SrcSpan's
5455-- and the ordering of import lists.
@@ -57,7 +58,7 @@ matchIgnoringSrcSpans = genericQuery
5758 where
5859 genericQuery :: GenericQ (GenericQ Diff)
5960 genericQuery x y
60− -- 'ByteString' implements 'Data' instance manually and does not
61+ -- NOTE 'ByteString' implement 'Data' instance manually and does not
6162 -- implement 'toConstr', so we have to deal with it in a special way.
6263 | Just x' <- cast x,
6364 Just y' <- cast y =
@@ -70,10 +71,9 @@ matchIgnoringSrcSpans = genericQuery
7071 gzipWithQ
7172 ( genericQuery
7273 `extQ` srcSpanEq
73− `extQ` commentEq
74+ `extQ` hsModuleEq
7475 `extQ` sourceTextEq
7576 `extQ` hsDocStringEq
76− `extQ` importDeclQualifiedStyleEq
7777 `ext2Q` forLocated
7878 )
7979 x
@@ -81,23 +81,16 @@ matchIgnoringSrcSpans = genericQuery
8181 | otherwise = Different []
8282 srcSpanEq :: SrcSpan -> GenericQ Diff
8383 srcSpanEq _ _ = Same
84− commentEq :: Comment -> GenericQ Diff
85− commentEq (Comment _ x) d =
86− case cast d :: Maybe Comment of
84+ hsModuleEq :: HsModule GhcPs -> GenericQ Diff
85+ hsModuleEq hs0 hs1' =
86+ case cast hs1' :: Maybe (HsModule GhcPs) of
8787 Nothing -> Different []
88− Just (Comment _ y) ->
89− if x == y
90− then Same
91− else Different []
88+ Just hs1 ->
89+ matchIgnoringSrcSpans
90+ hs0 {hsmodImports = sortImports (hsmodImports hs0)}
91+ hs1 {hsmodImports = sortImports (hsmodImports hs1)}
9292 sourceTextEq :: SourceText -> GenericQ Diff
9393 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 []
10194 hsDocStringEq :: HsDocString -> GenericQ Diff
10295 hsDocStringEq str0 str1' =
10396 case cast str1' :: Maybe HsDocString of
@@ -115,7 +108,7 @@ matchIgnoringSrcSpans = genericQuery
115108 appendSpan :: SrcSpan -> Diff -> Diff
116109 appendSpan s (Different ss) | fresh && helpful = Different (s : ss)
117110 where
118− fresh = not $ any (`isSubspanOf` s) ss
111+ fresh = not $ any (flip isSubspanOf s) ss
119112 helpful = isGoodSrcSpan s
120113 appendSpan _ d = d
121114
src/Ormolu/Exception.hs+20−27
@@ -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,24 +45,15 @@ 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 ->
53− showParsingErr
54− "Formatting is not idempotent:"
55− loc
54+ showParsingErr "Formatting is not idempotent:" loc
5655 ["before: " ++ show left, "after: " ++ show right]
5756 ++ "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− ]
6357
6458-- | Inside this wrapper 'OrmoluException' will be caught and displayed
6559-- nicely using 'displayException'.
@@ -74,13 +68,12 @@ withPrettyOrmoluExceptions m = m `catch` h
7468 hPutStrLn stderr (displayException e)
7569 exitWith . ExitFailure $
7670 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
71+ -- Error code 1 is for `error` or `notImplemented`
72+ OrmoluCppEnabled _ -> 2
73+ OrmoluParsingFailed _ _ -> 3
74+ OrmoluOutputParsingFailed _ _ -> 4
75+ OrmoluASTDiffers _ _ -> 5
76+ OrmoluNonIdempotentOutput _ _ _ -> 6
8477
8578----------------------------------------------------------------------------
8679-- 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+117−135
@@ -1,5 +1,5 @@
1−{-# LANGUAGE LambdaCase #-}
21{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE StandaloneDeriving #-}
33{-# OPTIONS_GHC -fno-warn-orphans #-}
44
55-- | Parser for Haskell source code.
@@ -9,39 +9,34 @@ module Ormolu.Parser
99 )
1010where
1111
12−import Bag (bagToList)
1312import qualified CmdLineParser as GHC
1413import Control.Exception
14+import Control.Monad
1515import 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
20−import DynFlags as GHC
21−import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)
16+import Data.List ((\\), foldl', isPrefixOf)
17+import Data.Maybe (catMaybes)
18+import qualified DynFlags as GHC
2219import qualified FastString as GHC
23−import GHC hiding (IE, UnicodeSyntax)
24−import GHC.DynFlags (baseDynFlags)
20+import GHC hiding (IE, parseModule, parser)
2521import GHC.LanguageExtensions.Type (Extension (..))
22+import GHC.Paths (libdir)
2623import qualified HeaderInfo as GHC
27−import qualified HscTypes as GHC
2824import qualified Lexer as GHC
2925import Ormolu.Config
3026import Ormolu.Exception
3127import Ormolu.Parser.Anns
3228import Ormolu.Parser.CommentStream
3329import Ormolu.Parser.Result
34−import Ormolu.Processing.Preprocess (preprocess)
35−import Ormolu.Utils (incSpanLine, removeIndentation)
36−import qualified Panic as GHC
30+import qualified Outputable as GHC
3731import qualified Parser as GHC
32+import qualified SrcLoc as GHC
3833import qualified StringBuffer as GHC
3934
4035-- | Parse a complete module from string.
4136parseModule ::
4237 MonadIO m =>
4338 -- | Ormolu configuration
44− Config RegionDeltas ->
39+ Config ->
4540 -- | File name (only for source location annotations)
4641 FilePath ->
4742 -- | Input for parser
@@ -50,79 +45,32 @@ parseModule ::
5045 ( [GHC.Warn],
5146 Either (SrcSpan, String) ParseResult
5247 )
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
58− -- 'parsePragmasIntoDynFlags', because otherwise we might enable an
59− -- extension that was explicitly disabled in the file.
60− let baseFlags =
61− GHC.setGeneralFlag'
62− GHC.Opt_Haddock
63− (setDefaultExts baseDynFlags)
64− extraOpts = dynOptionToLocatedStr <$> cfgDynOptions
65− (warnings, dynFlags) <-
66− parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case
67− Right res -> pure res
68− Left err ->
69− let loc =
70− mkSrcSpan
71− (mkSrcLoc (GHC.mkFastString path) 1 1)
72− (mkSrcLoc (GHC.mkFastString path) 1 1)
73− in throwIO (OrmoluParsingFailed loc err)
74− let useRecordDot =
75− "record-dot-preprocessor" == pgm_F dynFlags
76− || any
77− (("RecordDotPreprocessor" ==) . moduleNameString)
78− (pluginModNames dynFlags)
79− pStateErrors = \pstate ->
80− let errs = bagToList $ GHC.getErrorMessages pstate dynFlags
81− fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)
82− in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of
83− [] -> Nothing
84− err : _ ->
85− -- Show instance returns a short error message
86− Just (fixupErrSpan (errMsgSpan err), show err)
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− }
117− return (warnings, r)
118−
119−-- | Enable all language extensions that we think should be enabled by
120−-- default for ease of use.
121−setDefaultExts :: DynFlags -> DynFlags
122−setDefaultExts flags = L.foldl' xopt_set flags autoExts
123− where
124− autoExts = allExts L.\\ manualExts
125− allExts = [minBound .. maxBound]
48+parseModule Config {..} path input' = liftIO $ do
49+ let (input, extraComments) = stripLinePragmas path input'
50+ (ws, dynFlags) <- ghcWrapper $ do
51+ dynFlags0 <- initDynFlagsPure path input
52+ (dynFlags1, _, ws) <-
53+ GHC.parseDynamicFilePragma
54+ dynFlags0
55+ (dynOptionToLocatedStr <$> cfgDynOptions)
56+ return (ws, GHC.setGeneralFlag' GHC.Opt_Haddock dynFlags1)
57+ -- NOTE It's better to throw this outside of 'ghcWrapper' because
58+ -- otherwise the exception will be wrapped as a GHC panic, which we don't
59+ -- want.
60+ when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
61+ throwIO (OrmoluCppEnabled path)
62+ let r = case runParser GHC.parseModule dynFlags path input of
63+ GHC.PFailed _ ss m ->
64+ Left (ss, GHC.showSDoc dynFlags m)
65+ GHC.POk pstate pmod ->
66+ let (comments, exts) = mkCommentStream extraComments pstate
67+ in Right ParseResult
68+ { prParsedSource = pmod,
69+ prAnns = mkAnns pstate,
70+ prCommentStream = comments,
71+ prExtensions = exts
72+ }
73+ return (ws, r)
12674
12775-- | Extensions that are not enabled automatically and should be activated
12876-- by user.
@@ -143,13 +91,55 @@ manualExts =
14391 MonadComprehensions,
14492 UnboxedSums,
14593 UnicodeSyntax, -- gives special meanings to operators like (→)
146− TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this
94+ TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this
14795 -- apparently interferes with QuasiQuotes in
14896 -- weird ways
149− ImportQualifiedPost -- affects how Ormolu renders imports, so the
150− -- decision of enabling this style is left to the user
15197 ]
15298
99+----------------------------------------------------------------------------
100+-- Helpers (taken from ghc-exactprint)
101+
102+-- | Requires GhcMonad constraint because there is no pure variant of
103+-- 'parseDynamicFilePragma'. Yet, in constrast to 'initDynFlags', it does
104+-- not (try to) read the file at filepath, but solely depends on the module
105+-- source in the input string.
106+--
107+-- Passes "-hide-all-packages" to the GHC API to prevent parsing of package
108+-- environment files. However this only works if there is no invocation of
109+-- 'setSessionDynFlags' before calling 'initDynFlagsPure'. See GHC tickets
110+-- #15513, #15541.
111+initDynFlagsPure ::
112+ GHC.GhcMonad m =>
113+ -- | Module path
114+ FilePath ->
115+ -- | Module contents
116+ String ->
117+ -- | Dynamic flags for that module
118+ m GHC.DynFlags
119+initDynFlagsPure fp input = do
120+ -- I was told we could get away with using the 'unsafeGlobalDynFlags'. as
121+ -- long as 'parseDynamicFilePragma' is impure there seems to be no reason
122+ -- to use it.
123+ dflags0 <- setDefaultExts <$> GHC.getSessionDynFlags
124+ let tokens = GHC.getOptions dflags0 (GHC.stringToStringBuffer input) fp
125+ (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 tokens
126+ -- Turn this on last to avoid T10942
127+ let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream
128+ -- Prevent parsing of .ghc.environment.* "package environment files"
129+ (dflags3, _, _) <-
130+ GHC.parseDynamicFlagsCmdLine
131+ dflags2
132+ [GHC.noLoc "-hide-all-packages"]
133+ _ <- GHC.setSessionDynFlags dflags3
134+ return dflags3
135+
136+-- | Default runner of 'GHC.Ghc' action in 'IO'.
137+ghcWrapper :: GHC.Ghc a -> IO a
138+ghcWrapper act =
139+ let GHC.FlushOut flushOut = GHC.defaultFlushOut
140+ in GHC.runGhc (Just libdir) act
141+ `finally` flushOut
142+
153143-- | Run a 'GHC.P' computation.
154144runParser ::
155145 -- | Computation to run
@@ -168,52 +158,44 @@ runParser parser flags filename input = GHC.unP parser parseState
168158 buffer = GHC.stringToStringBuffer input
169159 parseState = GHC.mkPState flags buffer location
170160
171−-- | Wrap GHC's 'Severity' to add 'Ord' instance.
172−newtype SeverityOrd = SeverityOrd Severity
161+-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into
162+-- comments.
163+stripLinePragmas :: FilePath -> String -> (String, [Located String])
164+stripLinePragmas path = unlines' . unzip . findLines path . lines
165+ where
166+ unlines' (a, b) = (unlines a, catMaybes b)
173167
174−instance Eq SeverityOrd where
175− s1 == s2 = compare s1 s2 == EQ
168+findLines :: FilePath -> [String] -> [(String, Maybe (Located String))]
169+findLines path = zipWith (checkLine path) [1 ..]
176170
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
171+checkLine :: FilePath -> Int -> String -> (String, Maybe (Located String))
172+checkLine path line s
173+ | "{-# LINE" `isPrefixOf` s =
174+ let (pragma, res) = getPragma s
175+ size = length pragma
176+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
177+ in (res, Just $ L ss pragma)
178+ | "#!" `isPrefixOf` s =
179+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))
180+ in ("", Just $ L ss s)
181+ | otherwise = (s, Nothing)
182+ where
183+ mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line
189184
190−----------------------------------------------------------------------------
191−-- Helpers taken from HLint
185+getPragma :: String -> (String, String)
186+getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"
187+getPragma s@(x : xs)
188+ | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)
189+ | otherwise =
190+ let (prag, remline) = getPragma xs
191+ in (x : prag, ' ' : remline)
192192
193−parsePragmasIntoDynFlags ::
194− -- | Pre-set 'DynFlags'
195− DynFlags ->
196− -- | Extra options (provided by user)
197− [Located String] ->
198− -- | File name (only for source location annotations)
199− FilePath ->
200− -- | Input for parser
201− String ->
202− IO (Either String ([GHC.Warn], DynFlags))
203−parsePragmasIntoDynFlags flags extraOpts filepath str =
204− catchErrors $ do
205− let opts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath
206− (flags', leftovers, warnings) <-
207− parseDynamicFilePragma flags (opts <> extraOpts)
208− case NE.nonEmpty leftovers of
209− Nothing -> return ()
210− Just unrecognizedOpts ->
211− throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts))
212− let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream
213− return $ Right (warnings, flags'')
193+-- | Enable all language extensions that we think should be enabled by
194+-- default for ease of use.
195+setDefaultExts :: DynFlags -> DynFlags
196+setDefaultExts flags = foldl' GHC.xopt_set flags autoExts
214197 where
215− catchErrors act =
216− GHC.handleGhcException
217− reportErr
218− (GHC.handleSourceError reportErr act)
219− reportErr e = return $ Left (show e)
198+ autoExts = allExts \\ manualExts
199+ allExts = [minBound .. maxBound]
200+
201+deriving instance Bounded Extension
src/Ormolu/Parser/CommentStream.hs+65−154
@@ -1,77 +1,78 @@
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 . getLoc) 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)
71− ++ concatMap
72− (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
65+ ++ concatMap (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)
7366 (GHC.annotations_comments pstate)
74− (shebangs, otherExtraComments) = extractShebangs extraComments
67+
68+-- | Test whether a 'Comment' looks like a Haddock following a definition,
69+-- i.e. something starting with @-- ^@.
70+isPrevHaddock :: Comment -> Bool
71+isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x
72+
73+-- | Is this comment multiline-style?
74+isMultilineComment :: Comment -> Bool
75+isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x
7576
7677-- | Pretty-print a 'CommentStream'.
7778showCommentStream :: CommentStream -> String
@@ -82,117 +83,28 @@ showCommentStream (CommentStream xs) =
8283 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str
8384
8485----------------------------------------------------------------------------
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)
86+-- Helpers
9387
9488-- | Normalize comment string. Sometimes one multi-line comment is turned
9589-- into several lines for subsequent outputting with correct indentation for
9690-- 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)
91+mkComment :: RealLocated String -> RealLocated Comment
92+mkComment (L l s) =
93+ L l . Comment . fmap dropTrailing $
94+ if "{-" `isPrefixOf` s
95+ then case NE.nonEmpty (lines s) of
96+ Nothing -> s :| []
97+ Just (x :| xs) ->
98+ let getIndent y =
99+ if all isSpace y
100+ then startIndent
101+ else length (takeWhile isSpace y)
102+ n = minimum (startIndent : fmap getIndent xs)
103+ in x :| (drop n <$> xs)
104+ else s :| []
105105 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
106+ dropTrailing = dropWhileEnd isSpace
132107 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
196108
197109-- | Get a 'String' from 'GHC.AnnotationComment'.
198110unAnnotationComment :: GHC.AnnotationComment -> Maybe String
@@ -214,13 +126,12 @@ toRealSpan :: Located a -> Maybe (RealLocated a)
214126toRealSpan (L (RealSrcSpan l) a) = Just (L l a)
215127toRealSpan _ = Nothing
216128
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
129+-- | If a given comment is a pragma, return it in parsed form in 'Right'.
130+-- Otherwise return the original comment unchanged.
131+partitionComments ::
132+ RealLocated String ->
133+ Either (RealLocated String) Pragma
134+partitionComments input =
135+ case parsePragma (unLoc input) of
136+ Nothing -> Left input
137+ Just pragma -> Right pragma
src/Ormolu/Parser/Pragma.hs+11−14
@@ -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
@@ -68,15 +68,12 @@ tokenize input =
6868 location = mkRealSrcLoc (mkFastString "") 1 1
6969 buffer = stringToStringBuffer input
7070 parseState = L.mkPStatePure parserFlags buffer location
71− parserFlags =
72− L.mkParserFlags'
73− ES.empty
74− ES.empty
75− (newSimpleUnitId (ComponentId (mkFastString "")))
76− True
77− True
78− True
79− True
71+ parserFlags = L.ParserFlags
72+ { L.pWarningFlags = ES.empty,
73+ L.pExtensionFlags = ES.empty,
74+ L.pThisPackage = newSimpleUnitId (ComponentId (mkFastString "")),
75+ L.pExtsBitmap = 0xffffffffffffffff
76+ }
8077
8178-- | Haskell lexer.
8279pLexer :: L.P [L.Token]
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+6−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,7 @@ 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 (p_hsModule prExtensions prParsedSource)
25+ (mkSpanStream prParsedSource)
26+ prCommentStream
27+ prAnns
src/Ormolu/Printer/Combinators.hs+30−41
@@ -1,7 +1,6 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE GADTs #-}
31{-# LANGUAGE LambdaCase #-}
42{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
54
65-- | Printing combinators. The definitions here are presented in such an
76-- order so you can just go through the Haddocks and by the end of the file
@@ -21,7 +20,6 @@ module Ormolu.Printer.Combinators
2120 space,
2221 newline,
2322 inci,
24− inciIf,
2523 located,
2624 located',
2725 switchLayout,
@@ -52,57 +50,57 @@ module Ormolu.Printer.Combinators
5250
5351 -- ** Literals
5452 comma,
55− commaDel,
56− equals,
5753
58− -- ** Stateful markers
59− SpanMark (..),
60− spanMarkSpan,
54+ -- ** Comments
6155 HaddockStyle (..),
62− setSpanMark,
63− getSpanMark,
56+ setLastCommentSpan,
57+ getLastCommentSpan,
6458 )
6559where
6660
6761import Control.Monad
62+import Data.Data (Data)
6863import Data.List (intersperse)
6964import Data.Text (Text)
7065import Ormolu.Printer.Comments
7166import Ormolu.Printer.Internal
67+import Ormolu.Utils (isModule)
7268import SrcLoc
7369
7470----------------------------------------------------------------------------
7571-- Basic
7672
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−
8673-- | Enter a 'Located' entity. This combinator handles outputting comments
8774-- and sets layout (single-line vs multi-line) for the inner computation.
8875-- Roughly, the rule for using 'located' is that every time there is a
8976-- 'Located' wrapper, it should be “discharged” with a corresponding
9077-- 'located' invocation.
9178located ::
79+ Data a =>
9280 -- | Thing to enter
9381 Located a ->
9482 -- | How to render inner value
9583 (a -> R ()) ->
9684 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
85+located loc f = do
86+ let withRealLocated (L l a) g =
87+ case l of
88+ UnhelpfulSpan _ -> return ()
89+ RealSrcSpan l' -> g (L l' a)
90+ withRealLocated loc spitPrecedingComments
91+ let setEnclosingSpan =
92+ case getLoc loc of
93+ UnhelpfulSpan _ -> id
94+ RealSrcSpan orf ->
95+ if isModule (unLoc loc)
96+ then id
97+ else withEnclosingSpan orf
98+ setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))
99+ withRealLocated loc spitFollowingComments
103100
104101-- | A version of 'located' with arguments flipped.
105102located' ::
103+ Data a =>
106104 -- | How to render inner value
107105 (a -> R ()) ->
108106 -- | Thing to enter
@@ -185,12 +183,10 @@ sepSemi f xs = vlayout singleLine multiLine
185183 xs' ->
186184 if ub
187185 then do
188− txt "{"
189− space
190− sep (txt ";" >> space) (dontUseBraces . f) xs'
191− space
192− txt "}"
193− else sep (txt ";" >> space) f xs'
186+ txt "{ "
187+ sep (txt "; ") (dontUseBraces . f) xs'
188+ txt " }"
189+ else sep (txt "; ") f xs'
194190 multiLine =
195191 sep newline (dontUseBraces . f) xs
196192
@@ -203,7 +199,6 @@ data BracketStyle
203199 N
204200 | -- | Shifted one level
205201 S
206− deriving (Eq, Show)
207202
208203-- | Surround given entity by backticks.
209204backticks :: R () -> R ()
@@ -280,7 +275,9 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
280275 then newline >> inci m
281276 else space >> sitcc m
282277 newline
283− inciIf (style == S) (txt close)
278+ case style of
279+ N -> txt close
280+ S -> inci (txt close)
284281
285282----------------------------------------------------------------------------
286283-- Literals
@@ -288,11 +285,3 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)
288285-- | Print @,@.
289286comma :: R ()
290287comma = 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 (getLoc 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 (getLoc 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+110−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,
@@ -68,6 +62,7 @@ import Ormolu.Parser.CommentStream
6862import Ormolu.Printer.SpanStream
6963import Ormolu.Utils (showOutputable)
7064import Outputable (Outputable)
65+import SrcLoc
7166
7267----------------------------------------------------------------------------
7368-- The 'R' monad
@@ -79,44 +74,43 @@ newtype R a = R (ReaderT RC (State SC) a)
7974
8075-- | Reader context of 'R'. This should be used when we control rendering by
8176-- 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− }
77+data RC
78+ = RC
79+ { -- | Indentation level, as the column index we need to start from after
80+ -- a newline if we break lines
81+ rcIndent :: !Int,
82+ -- | Current layout
83+ rcLayout :: Layout,
84+ -- | Spans of enclosing elements of AST
85+ rcEnclosingSpans :: [RealSrcSpan],
86+ -- | Collection of annotations
87+ rcAnns :: Anns,
88+ -- | If the last expression in the layout can use braces
89+ rcCanUseBraces :: Bool
90+ }
9791
9892-- | 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− }
93+data SC
94+ = SC
95+ { -- | Index of the next column to render
96+ scColumn :: !Int,
97+ -- | Rendered source code so far
98+ scBuilder :: Builder,
99+ -- | Span stream
100+ scSpanStream :: SpanStream,
101+ -- | Comment stream
102+ scCommentStream :: CommentStream,
103+ -- | Pending comment lines (in reverse order) to be inserted before next
104+ -- newline, 'Int' is the indentation level
105+ scPendingComments :: ![(CommentPosition, Int, Text)],
106+ -- | Whether the current line is “dirty”, that is, already contains
107+ -- atoms that can have comments attached to them
108+ scDirtyLine :: !Bool,
109+ -- | Whether to output a space before the next output
110+ scRequestedDelimiter :: !RequestedDelimiter,
111+ -- | Span of last output comment
112+ scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))
113+ }
120114
121115-- | Make sure next output is delimited by one of the following.
122116data RequestedDelimiter
@@ -158,55 +152,32 @@ runR ::
158152 CommentStream ->
159153 -- | Annotations
160154 Anns ->
161− -- | Use Record Dot Syntax
162− Bool ->
163155 -- | Resulting rendition
164156 Text
165−runR (R m) sstream cstream anns recDot =
157+runR (R m) sstream cstream anns =
166158 TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc
167159 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− }
160+ rc = RC
161+ { rcIndent = 0,
162+ rcLayout = MultiLine,
163+ rcEnclosingSpans = [],
164+ rcAnns = anns,
165+ rcCanUseBraces = False
166+ }
167+ sc = SC
168+ { scColumn = 0,
169+ scBuilder = mempty,
170+ scSpanStream = sstream,
171+ scCommentStream = cstream,
172+ scPendingComments = [],
173+ scDirtyLine = False,
174+ scRequestedDelimiter = VeryBeginning,
175+ scLastCommentSpan = Nothing
176+ }
189177
190178----------------------------------------------------------------------------
191179-- Internal functions
192180
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−
210181-- | Output a fixed 'Text' fragment. The argument may not contain any line
211182-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like
212183-- keywords and pipes @|@ in functional dependencies.
@@ -218,15 +189,7 @@ txt ::
218189 -- | 'Text' to output
219190 Text ->
220191 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
192+txt = spit False False
230193
231194-- | Output 'Outputable' fragment of AST. This can be used to output numeric
232195-- literals and similar. Everything that doesn't have inner structure but
@@ -235,61 +198,48 @@ atom ::
235198 Outputable a =>
236199 a ->
237200 R ()
238−atom = spit Atom . T.pack . showOutputable
201+atom = spit True False . T.pack . showOutputable
239202
240203-- | Low-level non-public helper to define 'txt' and 'atom'.
241204spit ::
242− -- | Type of the thing to spit
243− SpitType ->
205+ -- | Should we mark the line as dirty?
206+ Bool ->
207+ -- | Used during outputting of pending comments?
208+ Bool ->
244209 -- | 'Text' to output
245210 Text ->
246211 R ()
247−spit _ "" = return ()
248−spit stype text = do
212+spit dirty printingComments txt' = do
249213 requestedDel <- R (gets scRequestedDelimiter)
250− pendingComments <- R (gets scPendingComments)
251− when (stype == InterferingText && not (null pendingComments)) newline
252214 case requestedDel of
253215 RequestedNewline -> do
254216 R . modify $ \sc ->
255217 sc
256218 { scRequestedDelimiter = RequestedNothing
257219 }
258− case stype of
259− CommentPart -> newlineRaw
260− _ -> newline
220+ if printingComments
221+ then newlineRaw
222+ else newline
261223 _ -> return ()
262224 R $ do
263225 i <- asks rcIndent
264226 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)
227+ let spaces =
228+ if c < i
229+ then T.replicate (i - c) " "
230+ else bool mempty " " (requestedDel == RequestedSpace)
231+ indentedTxt = spaces <> txt'
272232 modify $ \sc ->
273233 sc
274234 { scBuilder = scBuilder sc <> fromText indentedTxt,
275235 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,
236+ scDirtyLine = scDirtyLine sc || dirty,
287237 scRequestedDelimiter = RequestedNothing,
288− scSpanMark =
289− -- If there are pending comments, do not reset last comment
238+ scLastCommentSpan =
239+ -- NOTE If there are pending comments, do not reset last comment
290240 -- location.
291− if (stype == CommentPart) || (not . null . scPendingComments) sc
292− then scSpanMark sc
241+ if printingComments || (not . null . scPendingComments) sc
242+ then scLastCommentSpan sc
293243 else Nothing
294244 }
295245
@@ -320,22 +270,21 @@ space = R . modify $ \sc ->
320270-- hard to output more than one blank newline in a row.
321271newline :: R ()
322272newline = do
323− indent <- R (gets scIndent)
324273 cs <- reverse <$> R (gets scPendingComments)
325274 case cs of
326275 [] -> newlineRaw
327− ((position, _) : _) -> do
276+ ((position, _, _) : _) -> do
328277 case position of
329278 OnTheSameLine -> space
330279 OnNextLine -> newlineRaw
331− R . forM_ cs $ \(_, text) ->
280+ R . forM_ cs $ \(_, indent, txt') ->
332281 let modRC rc =
333282 rc
334283 { rcIndent = indent
335284 }
336285 R m = do
337− unless (T.null text) $
338− spit CommentPart text
286+ unless (T.null txt') $
287+ spit False True txt'
339288 newlineRaw
340289 in local modRC m
341290 R . modify $ \sc ->
@@ -356,8 +305,7 @@ newlineRaw = R . modify $ \sc ->
356305 VeryBeginning -> builderSoFar
357306 _ -> builderSoFar <> "\n",
358307 scColumn = 0,
359− scIndent = 0,
360− scThisLineSpans = [],
308+ scDirtyLine = False,
361309 scRequestedDelimiter = case scRequestedDelimiter sc of
362310 AfterNewline -> RequestedNewline
363311 RequestedNewline -> RequestedNewline
@@ -365,9 +313,10 @@ newlineRaw = R . modify $ \sc ->
365313 _ -> AfterNewline
366314 }
367315
368−-- | Return 'True' if we should print record dot syntax.
369−useRecordDot :: R Bool
370−useRecordDot = R (asks rcUseRecDot)
316+-- | Check if the current line is “dirty”, that is, there is something on it
317+-- that can have comments attached to it.
318+isLineDirty :: R Bool
319+isLineDirty = R (gets scDirtyLine)
371320
372321-- | Increase indentation level by one indentation step for the inner
373322-- computation. 'inci' should be used when a part of code must be more
@@ -384,7 +333,8 @@ inci (R m) = R (local modRC m)
384333
385334-- | Set indentation level for the inner computation equal to current
386335-- column. This makes sure that the entire inner block is uniformly
387−-- \"shifted\" to the right.
336+-- \"shifted\" to the right. Only works (and makes sense) when enclosing
337+-- layout is multi-line.
388338sitcc :: R () -> R ()
389339sitcc (R m) = do
390340 requestedDel <- R (gets scRequestedDelimiter)
@@ -392,9 +342,16 @@ sitcc (R m) = do
392342 c <- R (gets scColumn)
393343 let modRC rc =
394344 rc
395− { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))
345+ { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)
396346 }
397− R (local modRC m)
347+ vlayout (R m) . R $ do
348+ modify $ \sc ->
349+ sc
350+ { scRequestedDelimiter = case requestedDel of
351+ RequestedSpace -> RequestedNothing
352+ other -> other
353+ }
354+ local modRC m
398355
399356-- | Set 'Layout' for internal computation.
400357enterLayout :: Layout -> R () -> R ()
@@ -435,10 +392,11 @@ registerPendingCommentLine ::
435392 -- | 'Text' to output
436393 Text ->
437394 R ()
438−registerPendingCommentLine position text = R $ do
395+registerPendingCommentLine position txt' = R $ do
396+ i <- asks rcIndent
439397 modify $ \sc ->
440398 sc
441− { scPendingComments = (position, text) : scPendingComments sc
399+ { scPendingComments = (position, i, txt') : scPendingComments sc
442400 }
443401
444402-- | Drop elements that begin before or at the same place as given
@@ -497,29 +455,6 @@ withEnclosingSpan spn (R m) = R (local modRC m)
497455 { rcEnclosingSpans = spn : rcEnclosingSpans rc
498456 }
499457
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−
523458-- | Haddock string style.
524459data HaddockStyle
525460 = -- | @-- |@
@@ -532,18 +467,20 @@ data HaddockStyle
532467 Named String
533468
534469-- | Set span of last output comment.
535−setSpanMark ::
536− -- | Span mark to set
537− SpanMark ->
470+setLastCommentSpan ::
471+ -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment
472+ Maybe HaddockStyle ->
473+ -- | Location of last printed comment
474+ RealSrcSpan ->
538475 R ()
539−setSpanMark spnMark = R . modify $ \sc ->
476+setLastCommentSpan mhStyle spn = R . modify $ \sc ->
540477 sc
541− { scSpanMark = Just spnMark
478+ { scLastCommentSpan = Just (mhStyle, spn)
542479 }
543480
544481-- | Get span of last output comment.
545−getSpanMark :: R (Maybe SpanMark)
546−getSpanMark = R (gets scSpanMark)
482+getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))
483+getLastCommentSpan = R (gets scLastCommentSpan)
547484
548485----------------------------------------------------------------------------
549486-- Annotations
@@ -567,7 +504,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)
567504
568505-- | Return 'True' if we can use braces in this context.
569506canUseBraces :: R Bool
570−canUseBraces = R (asks rcCanUseBraces)
507+canUseBraces = R $ asks rcCanUseBraces
571508
572509----------------------------------------------------------------------------
573510-- Constants
src/Ormolu/Printer/Meat/Common.hs+22−25
@@ -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,22 +156,17 @@ 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
165163 if isFirst
166164 then case hstyle of
167− Pipe -> txt "-- |"
168− Caret -> txt "-- ^"
169− Asterisk n -> txt ("-- " <> T.replicate n "*")
165+ Pipe -> txt "-- |" >> space
166+ Caret -> txt "-- ^" >> space
167+ Asterisk n -> txt ("-- " <> T.replicate n "*") >> space
170168 Named name -> p_hsDocName name
171− else newline >> txt "--"
172− space
169+ else newline >> txt "--" >> space
173170 unless (T.null x) (txt x)
174171 when needsNewline newline
175172 case l of
@@ -177,8 +174,8 @@ p_hsDocString hstyle needsNewline (L l str) = do
177174 -- It's often the case that the comment itself doesn't have a span
178175 -- attached to it and instead its location can be obtained from
179176 -- nearest enclosing span.
180− getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)
181− RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)
177+ getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))
178+ RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn
182179
183180-- | Print anchor of named doc section.
184181p_hsDocName :: String -> R ()
src/Ormolu/Printer/Meat/Declaration.hs+111−176
@@ -7,14 +7,14 @@
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
17−import GHC hiding (InlinePragma)
17+import GHC
1818import OccName (occNameFS)
1919import Ormolu.Printer.Combinators
2020import Ormolu.Printer.Meat.Common
@@ -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 (L _ 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 (L _ p)) = patBindNames p
248+patBindNames (BangPat NoExt (L _ p)) = patBindNames p
249+patBindNames (ParPat NoExt (L _ p)) = patBindNames p
250+patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps
251+patBindNames (AsPat NoExt (L _ n) (L _ p)) = n : patBindNames p
252+patBindNames (SumPat NoExt (L _ p) _ _) = patBindNames p
253+patBindNames (ViewPat NoExt _ (L _ p)) = patBindNames p
254+patBindNames (SplicePat NoExt _) = []
255+patBindNames (LitPat NoExt _) = []
256+patBindNames (SigPat _ (L _ 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 NoExt) = notImplemented "XPat"
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 = 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+58−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 (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 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,18 @@ conArgsSpans = \case
177163conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]
178164conTyVarsSpans = \case
179165 HsQTvs {..} -> getLoc <$> hsq_explicit
180− XLHsQTyVars x -> noExtCon x
166+ XLHsQTyVars NoExt -> []
167+
168+p_forallBndrs ::
169+ [LHsTyVarBndr GhcPs] ->
170+ R ()
171+p_forallBndrs = \case
172+ [] -> return ()
173+ bndrs -> do
174+ txt "forall"
175+ space
176+ sep space (located' p_hsTyVarBndr) bndrs
177+ txt "."
181178
182179p_lhsContext ::
183180 LHsContext GhcPs ->
@@ -204,9 +201,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
204201 let derivingWhat = located deriv_clause_tys $ \case
205202 [] -> txt "()"
206203 xs ->
207− parens N $
204+ parens N . sitcc $
208205 sep
209− commaDel
206+ (comma >> breakpoint)
210207 (sitcc . located' p_hsType . hsib_body)
211208 xs
212209 space
@@ -235,9 +232,9 @@ p_hsDerivingClause HsDerivingClause {..} = do
235232 txt "via"
236233 space
237234 located hsib_body p_hsType
238− ViaStrategy (XHsImplicitBndrs x) ->
239− noExtCon x
240−p_hsDerivingClause (XHsDerivingClause x) = noExtCon x
235+ ViaStrategy (XHsImplicitBndrs NoExt) ->
236+ notImplemented "XHsImplicitBndrs"
237+p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"
241238
242239----------------------------------------------------------------------------
243240-- Helpers
@@ -246,16 +243,3 @@ isInfix :: LexicalFixity -> Bool
246243isInfix = \case
247244 Infix -> True
248245 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+7−9
@@ -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,21 +25,18 @@ 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.
3132p_foreignTypeSig :: ForeignDecl GhcPs -> R ()
3233p_foreignTypeSig fd = do
3334 breakpoint
34− inci
35− . switchLayout
36− [ getLoc (fd_name fd),
37− (getLoc . hsib_body . fd_sig_ty) fd
38− ]
39− $ do
40− p_rdrName (fd_name fd)
41− p_typeAscription (HsWC NoExtField (fd_sig_ty fd))
35+ -- Switch into the layout of the signature, to allow us to pull name and
36+ -- signature onto a single line.
37+ inci . switchLayout [getLoc . hsib_body $ fd_sig_ty fd] $ do
38+ p_rdrName (fd_name fd)
39+ p_typeAscription (HsWC NoExt (fd_sig_ty fd))
4240
4341-- | Printer for 'ForeignImport'.
4442--
src/Ormolu/Printer/Meat/Declaration/Instance.hs+28−22
@@ -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 {..}}} ->
110− p_dataDecl style feqn_tycon (map typeArgToType feqn_pats) feqn_fixity feqn_rhs
111− DataFamInstDecl {dfid_eqn = HsIB {hsib_body = XFamEqn {}}} ->
112− notImplemented "XFamEqn"
113− DataFamInstDecl {dfid_eqn = XHsImplicitBndrs {}} ->
114− notImplemented "XHsImplicitBndrs"
117+ DataFamInstDecl {..} -> do
118+ let HsIB {..} = dfid_eqn
119+ FamEqn {..} = hsib_body
120+ p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs
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+23−22
@@ -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,55 @@ module Ormolu.Printer.Meat.Declaration.Rule
78where
89
910import BasicTypes
10−import Control.Monad (unless)
1111import GHC
1212import Ormolu.Printer.Combinators
1313import Ormolu.Printer.Meat.Common
1414import Ormolu.Printer.Meat.Declaration.Signature
1515import Ormolu.Printer.Meat.Declaration.Value
16−import Ormolu.Printer.Meat.Type
16+import Ormolu.Utils
1717
1818p_ruleDecls :: RuleDecls GhcPs -> R ()
1919p_ruleDecls = \case
20− HsRules NoExtField _ xs ->
21− pragma "RULES" $
20+ HsRules NoExt _ xs ->
21+ pragma "RULES" . sitcc $
2222 sep breakpoint (sitcc . located' p_ruleDecl) xs
23− XRuleDecls x -> noExtCon x
23+ XRuleDecls NoExt -> notImplemented "XRuleDecls"
2424
2525p_ruleDecl :: RuleDecl GhcPs -> R ()
2626p_ruleDecl = \case
27− HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do
27+ HsRule NoExt ruleName activation ruleBndrs lhs rhs -> do
2828 located ruleName p_ruleName
2929 space
3030 p_activation activation
3131 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
32+ p_ruleBndrs ruleBndrs
4233 breakpoint
4334 inci $ do
4435 located lhs p_hsExpr
4536 space
46− equals
37+ txt "="
4738 inci $ do
4839 breakpoint
4940 located rhs p_hsExpr
50− XRuleDecl x -> noExtCon x
41+ XRuleDecl NoExt -> notImplemented "XRuleDecl"
5142
5243p_ruleName :: (SourceText, RuleName) -> R ()
53−p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)
44+p_ruleName (_, name) = atom $ HsString NoSourceText name
45+
46+p_ruleBndrs :: [LRuleBndr GhcPs] -> R ()
47+p_ruleBndrs [] = return ()
48+p_ruleBndrs bndrs =
49+ switchLayout (getLoc <$> bndrs) $ do
50+ txt "forall"
51+ breakpoint
52+ inci $ do
53+ sitcc $ sep breakpoint (sitcc . located' p_ruleBndr) bndrs
54+ txt "."
5455
5556p_ruleBndr :: RuleBndr GhcPs -> R ()
5657p_ruleBndr = \case
57− RuleBndr NoExtField x -> p_rdrName x
58− RuleBndrSig NoExtField x hswc -> parens N $ do
58+ RuleBndr NoExt x -> p_rdrName x
59+ RuleBndrSig NoExt x hswc -> parens N $ do
5960 p_rdrName x
6061 p_typeAscription hswc
61− XRuleBndr x -> noExtCon x
62+ XRuleBndr NoExt -> notImplemented "XRuleBndr"
src/Ormolu/Printer/Meat/Declaration/Signature.hs+33−49
@@ -7,13 +7,13 @@ module Ormolu.Printer.Meat.Declaration.Signature
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+9−9
@@ -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
30− (case fixity of Infix -> True; _ -> False)
31− True
33+ (case fixity of { Infix -> True; _ -> False })
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+37−42
@@ -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 (isJust fdInjectivityAnn) 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,27 +56,26 @@ 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 ::
62+ Bool ->
6163 Located (FamilyResultSig GhcPs) ->
6264 Maybe (R ())
63−p_familyResultSigL l =
65+p_familyResultSigL injAnn l =
6466 case l of
6567 L _ a -> case a of
66− NoSig NoExtField -> Nothing
67− KindSig NoExtField k -> Just $ do
68− txt "::"
68+ NoSig NoExt -> Nothing
69+ KindSig NoExt k -> Just $ do
70+ if injAnn then txt "=" else txt "::"
6971 breakpoint
7072 located k p_hsType
71− TyVarSig NoExtField bndr -> Just $ do
72− equals
73+ TyVarSig NoExt bndr -> Just $ do
74+ if injAnn then txt "=" else txt "::"
7375 breakpoint
7476 located bndr p_hsTyVarBndr
75− XFamilyResultSig x ->
76− noExtCon x
77+ XFamilyResultSig NoExt ->
78+ notImplemented "XFamilyResultSig"
7779
7880p_injectivityAnn :: InjectivityAnn GhcPs -> R ()
7981p_injectivityAnn (InjectivityAnn a bs) = do
@@ -86,26 +88,19 @@ p_injectivityAnn (InjectivityAnn a bs) = do
8688 sep space p_rdrName bs
8789
8890p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R ()
89−p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do
90− case feqn_bndrs of
91− Nothing -> return ()
92− Just bndrs -> do
93− p_forallBndrs ForallInvis p_hsTyVarBndr bndrs
94− breakpoint
95− inciIf (not $ null feqn_bndrs) $ do
96− let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats
97− switchLayout famLhsSpn $
98− p_infixDefHelper
99− (isInfix feqn_fixity)
100− True
101− (p_rdrName feqn_tycon)
102− (located' p_hsType . typeArgToType <$> feqn_pats)
103− space
104− equals
105− breakpoint
106− inci (located feqn_rhs p_hsType)
107−p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x
108−p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x
91+p_tyFamInstEqn HsIB {..} = do
92+ let FamEqn {..} = hsib_body
93+ switchLayout (getLoc feqn_tycon : (getLoc <$> feqn_pats)) $
94+ p_infixDefHelper
95+ (isInfix feqn_fixity)
96+ inci
97+ (p_rdrName feqn_tycon)
98+ (located' p_hsType <$> feqn_pats)
99+ space
100+ txt "="
101+ breakpoint
102+ inci (located feqn_rhs p_hsType)
103+p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"
109104
110105----------------------------------------------------------------------------
111106-- Helpers
src/Ormolu/Printer/Meat/Declaration/Value.hs+342−453
@@ -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,24 +179,25 @@ 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
195195 let stdCase = sep breakpoint (located' p_pat) m_pats
196196 case style of
197197 Function name ->
198198 p_infixDefHelper
199199 isInfix
200− indentBody
200+ inci'
201201 (p_rdrName name)
202202 (located' p_pat <$> m_pats)
203203 PatternBind -> stdCase
@@ -212,32 +212,40 @@ 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 =
232− maybe
233− grhssSpan
234− (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)
240+ maybe grhssSpan
241+ (combineSrcSpans grhssSpan . srcLocSpan)
235242 endOfPats
236243 placement =
237244 case endOfPats of
238245 Nothing -> blockPlacement placer grhssGRHSs
239246 Just spn ->
240− if onTheSameLine spn grhssSpan
247+ if isOneLineSpan
248+ (mkSrcSpan spn (srcSpanStart grhssSpan))
241249 then blockPlacement placer grhssGRHSs
242250 else Normal
243251 p_body = do
@@ -253,18 +261,10 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
253261 txt "where"
254262 unless whereIsEmpty breakpoint
255263 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 "->"
264+ inci' $ do
264265 switchLayout [patGrhssSpan] $
265266 placeHanging placement p_body
266267 inci p_where
267−p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x
268268
269269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()
270270p_grhs = p_grhs' exprPlacement p_hsExpr
@@ -278,109 +278,79 @@ p_grhs' ::
278278 GroupStyle ->
279279 GRHS GhcPs (Located body) ->
280280 R ()
281−p_grhs' placer render style (GRHS NoExtField guards body) =
281+p_grhs' placer render style (GRHS NoExt guards body) =
282282 case guards of
283283 [] -> p_body
284284 xs -> do
285285 txt "|"
286286 space
287− sitcc (sep commaDel (sitcc . located' p_stmt) xs)
287+ sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)
288288 space
289− inci $ case style of
290− EqualSign -> equals
291− RightArrow -> txt "->"
289+ txt $ case style of
290+ EqualSign -> "="
291+ RightArrow -> "->"
292292 placeHanging placement p_body
293293 where
294294 placement =
295295 case endOfGuards of
296296 Nothing -> placer (unLoc body)
297297 Just spn ->
298− if onTheSameLine spn (getLoc body)
298+ if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))
299299 then placer (unLoc body)
300300 else Normal
301301 endOfGuards =
302302 case NE.nonEmpty guards of
303303 Nothing -> Nothing
304− Just gs -> (Just . getLoc . NE.last) gs
304+ Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
305305 p_body = located body render
306−p_grhs' _ _ _ (XGRHS x) = noExtCon x
306+p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
307307
308308p_hsCmd :: HsCmd GhcPs -> R ()
309309p_hsCmd = \case
310− HsCmdArrApp NoExtField body input arrType _ -> do
310+ HsCmdArrApp NoExt body input arrType _ -> do
311311 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
312+ space
313+ case arrType of
314+ HsFirstOrderApp -> txt "-<"
315+ HsHigherOrderApp -> txt "-<<"
316+ placeHanging (exprPlacement (unLoc input)) $
317+ located input p_hsExpr
318+ HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do
320319 located form p_hsExpr
321320 unless (null cmds) $ do
322321 breakpoint
323322 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))
324− HsCmdArrForm NoExtField form Infix _ [left, right] -> do
323+ HsCmdArrForm NoExt form Infix _ [left, right] -> do
325324 located left p_hsCmdTop
326325 space
327326 located form p_hsExpr
328327 placeHanging (cmdTopPlacement (unLoc right)) $
329328 located right p_hsCmdTop
330− HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"
329+ HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"
331330 HsCmdApp {} ->
332331 -- XXX Does this ever occur in the syntax tree? It does not seem like it
333332 -- does. Open an issue and ping @yumiova if this ever occurs in output.
334333 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 ->
334+ HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
335+ HsCmdPar NoExt c -> parens N (located c p_hsCmd)
336+ HsCmdCase NoExt e mgroup ->
338337 p_case cmdPlacement p_hsCmd e mgroup
339− HsCmdIf NoExtField _ if' then' else' ->
338+ HsCmdIf NoExt _ if' then' else' ->
340339 p_if cmdPlacement p_hsCmd if' then' else'
341− HsCmdLet NoExtField localBinds c ->
340+ HsCmdLet NoExt localBinds c ->
342341 p_let p_hsCmd localBinds c
343− HsCmdDo NoExtField es -> do
342+ HsCmdDo NoExt es -> do
344343 txt "do"
345344 newline
346345 inci . located es $
347− sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))
346+ sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
348347 HsCmdWrap {} -> notImplemented "HsCmdWrap"
349− XCmd x -> noExtCon x
348+ XCmd {} -> notImplemented "XCmd"
350349
351350p_hsCmdTop :: HsCmdTop GhcPs -> R ()
352351p_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)
352+ HsCmdTop NoExt cmd -> located cmd p_hsCmd
353+ XCmdTop {} -> notImplemented "XHsCmdTop"
384354
385355p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
386356p_stmt = p_stmt' exprPlacement p_hsExpr
@@ -395,36 +365,35 @@ p_stmt' ::
395365 Stmt GhcPs (Located body) ->
396366 R ()
397367p_stmt' placer render = \case
398− LastStmt NoExtField body _ _ -> located body render
399− BindStmt NoExtField p f _ _ -> do
400− located p p_pat
368+ LastStmt NoExt body _ _ -> located body render
369+ BindStmt NoExt l f _ _ -> do
370+ located l p_pat
401371 space
402372 txt "<-"
403− let loc = getLoc p
404− placement =
373+ let placement =
405374 case f of
406375 L l' x ->
407376 if isOneLineSpan
408− (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l'))
377+ (mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))
409378 then placer x
410379 else Normal
411− switchLayout [loc, getLoc f] $
380+ switchLayout [getLoc l, getLoc f] $
412381 placeHanging placement (located f render)
413382 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
414− BodyStmt NoExtField body _ _ -> located body render
415− LetStmt NoExtField binds -> do
383+ BodyStmt NoExt body _ _ -> located body render
384+ LetStmt NoExt binds -> do
416385 txt "let"
417386 space
418387 sitcc $ located binds p_hsLocalBinds
419388 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.
389+ -- NOTE 'ParStmt' should always be eliminated in 'gatherStmt' already,
390+ -- such that it never occurs in 'p_stmt''. Consequently, handling it
391+ -- here would be redundant.
423392 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'.
393+ TransStmt {..} -> do
394+ -- NOTE 'TransStmt' only needs to account for render printing itself,
395+ -- since pretty printing of relevant statements (e.g., in 'trS_stmts')
396+ -- is handled through 'gatherStmt'.
428397 case (trS_form, trS_by) of
429398 (ThenForm, Nothing) -> do
430399 txt "then"
@@ -453,11 +422,11 @@ p_stmt' placer render = \case
453422 RecStmt {..} -> do
454423 txt "rec"
455424 space
456− sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts
457− XStmtLR c -> noExtCon c
425+ sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
426+ XStmtLR {} -> notImplemented "XStmtLR"
458427
459428gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
460−gatherStmt (L _ (ParStmt NoExtField block _ _)) =
429+gatherStmt (L _ (ParStmt NoExt block _ _)) =
461430 foldr ((<>) . gatherStmtBlock) [] block
462431gatherStmt (L s stmt@TransStmt {..}) =
463432 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])
@@ -466,229 +435,183 @@ gatherStmt stmt = [[stmt]]
466435gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]
467436gatherStmtBlock (ParStmtBlock _ stmts _ _) =
468437 foldr (liftAppend . gatherStmt) [] stmts
469−gatherStmtBlock (XParStmtBlock x) = noExtCon x
438+gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"
470439
471440p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()
472441p_hsLocalBinds = \case
473− HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do
474− -- When in a single-line layout, there is a chance that the inner
442+ HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do
443+ let ssStart =
444+ either
445+ (srcSpanStart . getLoc)
446+ (srcSpanStart . getLoc)
447+ items =
448+ (Left <$> bagToList bag) ++ (Right <$> lsigs)
449+ p_item (Left x) = located x p_valDecl
450+ p_item (Right x) = located x p_sigDecl
451+ -- Assigns 'False' to the last element, 'True' to the rest.
452+ markInit :: [a] -> [(Bool, a)]
453+ markInit [] = []
454+ markInit (x : []) = [(False, x)]
455+ markInit (x : xs) = (True, x) : markInit xs
456+ -- NOTE When in a single-line layout, there is a chance that the inner
475457 -- elements will also contain semicolons and they will confuse the
476458 -- parser. so we request braces around every element except the last.
477459 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) ->
460+ sitcc $
461+ sepSemi
462+ (\(m, i) -> (if m then br else id) $ p_item i)
463+ (markInit $ sortOn ssStart items)
464+ HsValBinds NoExt _ -> notImplemented "HsValBinds"
465+ HsIPBinds NoExt (IPBinds NoExt xs) ->
494466 -- Second argument of IPBind is always Left before type-checking.
495− let p_ipBind (IPBind NoExtField (Left name) expr) = do
467+ let p_ipBind (IPBind NoExt (Left name) expr) = do
496468 atom name
497469 space
498− equals
470+ txt "="
499471 breakpoint
500472 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
473+ p_ipBind _ = notImplemented "XHsIPBinds"
505474 in sepSemi (located' p_ipBind) xs
506− HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"
507− EmptyLocalBinds NoExtField -> return ()
508− XHsLocalBindsLR x -> noExtCon x
475+ HsIPBinds NoExt _ -> notImplemented "HsIpBinds"
476+ EmptyLocalBinds NoExt -> return ()
477+ XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"
509478
510479p_hsRecField ::
511480 HsRecField' RdrName (LHsExpr GhcPs) ->
512481 R ()
513−p_hsRecField HsRecField {..} = do
482+p_hsRecField = \HsRecField {..} -> do
514483 p_rdrName hsRecFieldLbl
515484 unless hsRecPun $ do
516485 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)
486+ txt "="
487+ let placement = exprPlacement (unLoc hsRecFieldArg)
488+ placeHanging placement $ located hsRecFieldArg p_hsExpr
489+
490+p_hsTupArg :: HsTupArg GhcPs -> R ()
491+p_hsTupArg = \case
492+ Present NoExt x -> located x p_hsExpr
493+ Missing NoExt -> pure ()
494+ XTupArg {} -> notImplemented "XTupArg"
523495
524496p_hsExpr :: HsExpr GhcPs -> R ()
525497p_hsExpr = p_hsExpr' N
526498
527499p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()
528500p_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 ->
501+ HsVar NoExt name -> p_rdrName name
502+ HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"
503+ HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"
504+ HsRecFld NoExt x ->
533505 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
506+ Unambiguous NoExt name -> p_rdrName name
507+ Ambiguous NoExt name -> p_rdrName name
508+ XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"
509+ HsOverLabel NoExt _ v -> do
538510 txt "#"
539511 atom v
540− HsIPVar NoExtField (HsIPName name) -> do
512+ HsIPVar NoExt (HsIPName name) -> do
541513 txt "?"
542514 atom name
543− HsOverLit NoExtField v -> atom (ol_val v)
544− HsLit NoExtField lit ->
515+ HsOverLit NoExt v -> atom (ol_val v)
516+ HsLit NoExt lit ->
545517 case lit of
546518 HsString (SourceText stxt) _ -> p_stringLit stxt
547519 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt
548520 r -> atom r
549− HsLam NoExtField mgroup ->
521+ HsLam NoExt mgroup ->
550522 p_matchGroup Lambda mgroup
551− HsLamCase NoExtField mgroup -> do
523+ HsLamCase NoExt mgroup -> do
552524 txt "\\case"
553525 breakpoint
554526 inci (p_matchGroup LambdaCase mgroup)
555− HsApp NoExtField f x -> do
556− let -- In order to format function applications with multiple parameters
557− -- nicer, traverse the AST to gather the function and all the
558− -- parameters together.
559− gatherArgs f' knownArgs =
527+ HsApp NoExt f x -> do
528+ -- We hang only the last function argument. In order to do this, we only
529+ -- call 'placeHanging' on the topmost 'HsApp', and then use
530+ -- 'p_withoutHanging' for the descendants.
531+ let p_withoutHanging (HsApp NoExt f' x') = do
560532 case f' of
561− L _ (HsApp _ l r) -> gatherArgs l (r <| knownArgs)
562− _ -> (f', knownArgs)
563− (func, args) = gatherArgs f (x :| [])
564− -- We need to handle the last argument specially if it is a
565− -- hanging construct, so separate it from the rest.
566− (initp, lastp) = (NE.init args, NE.last args)
567− initSpan =
568− combineSrcSpans' $
569− getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp]
570− -- Hang the last argument only if the initial arguments span one
533+ L _ (HsApp _ _ _) -> located f' p_withoutHanging
534+ _ -> located f' (p_hsExpr' s)
535+ breakpoint
536+ inci $ located x' p_hsExpr
537+ p_withoutHanging e = p_hsExpr e
538+ -- Only use the hanging placement if the function spans a single
571539 -- line.
572540 placement =
573− if isOneLineSpan initSpan
574− then exprPlacement (unLoc lastp)
541+ if isOneLineSpan (getLoc f)
542+ then exprPlacement (unLoc x)
575543 else Normal
576− -- If the last argument is not hanging, just separate every argument as
577− -- usual. If it is hanging, print the initial arguments and hang the
578− -- last one. Also, use braces around the every argument except the last
579− -- one.
580− case placement of
581− Normal -> do
582− let -- Usually we want to bump indentation for arguments for the
583− -- sake of readability. However, when the function itself is a
584− -- do-block or case expression it is not a good idea. It seems
585− -- to be safe to always bump indentation when the function
586− -- expression is parenthesised.
587− doIndent =
588− case func of
589− L _ (HsPar NoExtField _) -> True
590− L _ (HsAppType NoExtField _ _) -> True
591− L _ (HsMultiIf NoExtField _) -> True
592− L spn _ -> isOneLineSpan spn
593− ub <-
594− getLayout <&> \case
595− SingleLine -> useBraces
596− MultiLine -> id
597− ub $ do
598− located func (p_hsExpr' s)
599− breakpoint
600− inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp
601− inciIf doIndent $ do
602− unless (null initp) breakpoint
603− located lastp p_hsExpr
604− Hanging -> do
605− useBraces . switchLayout [initSpan] $ do
606− located func (p_hsExpr' s)
607− breakpoint
608− sep breakpoint (located' p_hsExpr) initp
609− placeHanging placement $
610− located lastp p_hsExpr
611− HsAppType NoExtField e a -> do
544+ useBraces (located f p_withoutHanging)
545+ placeHanging placement $
546+ located x p_hsExpr
547+ HsAppType a e -> do
612548 located e p_hsExpr
613549 breakpoint
614550 inci $ do
615551 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 ()
621552 located (hswc_body a) p_hsType
622− OpApp NoExtField x op y -> do
553+ OpApp NoExt x op y -> do
623554 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
624− p_exprOpTree s (reassociateOpTree getOpName opTree)
625− NegApp NoExtField e _ -> do
555+ p_exprOpTree True s (reassociateOpTree getOpName opTree)
556+ NegApp NoExt e _ -> do
626557 txt "-"
627558 space
628559 located e p_hsExpr
629− HsPar NoExtField e ->
630− parens s (located e (dontUseBraces . p_hsExpr))
631− SectionL NoExtField x op -> do
560+ HsPar NoExt e -> parens s (located e p_hsExpr)
561+ SectionL NoExt x op -> do
632562 located x p_hsExpr
633563 breakpoint
634564 inci (located op p_hsExpr)
635− SectionR NoExtField op x -> do
565+ SectionR NoExt op x -> do
636566 located op p_hsExpr
637− useRecordDot' <- useRecordDot
638− let isRecordDot' = isRecordDot (unLoc op) (getLoc x)
639− unless (useRecordDot' && isRecordDot') breakpoint
567+ breakpoint
640568 inci (located x p_hsExpr)
641− ExplicitTuple NoExtField args boxity ->
569+ ExplicitTuple NoExt args boxity -> do
642570 let isSection = any (isMissing . unLoc) args
643571 isMissing = \case
644− Missing NoExtField -> True
572+ Missing NoExt -> True
645573 _ -> 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' =
574+ let parens' =
652575 case boxity of
653576 Boxed -> parens
654577 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 ->
578+ if isSection
579+ then
580+ switchLayout [] . parens' s $
581+ sep comma (located' p_hsTupArg) args
582+ else
583+ switchLayout (getLoc <$> args) . parens' s . sitcc $
584+ sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
585+ ExplicitSum NoExt tag arity e ->
663586 p_unboxedSum N tag arity (located e p_hsExpr)
664− HsCase NoExtField e mgroup ->
587+ HsCase NoExt e mgroup ->
665588 p_case exprPlacement p_hsExpr e mgroup
666− HsIf NoExtField _ if' then' else' ->
589+ HsIf NoExt _ if' then' else' ->
667590 p_if exprPlacement p_hsExpr if' then' else'
668− HsMultiIf NoExtField guards -> do
591+ HsMultiIf NoExt guards -> do
669592 txt "if"
670593 breakpoint
671− inci . inci $ sep newline (located' (p_grhs RightArrow)) guards
672− HsLet NoExtField localBinds e ->
594+ inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
595+ HsLet NoExt localBinds e ->
673596 p_let p_hsExpr localBinds e
674− HsDo NoExtField ctx es -> do
597+ HsDo NoExt ctx es -> do
675598 let doBody header = do
676599 txt header
677600 breakpoint
678601 ub <- layoutToBraces <$> getLayout
679602 inci $
680603 sepSemi
681− (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
604+ (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
682605 (unLoc es)
683− compBody = brackets N . located es $ \xs -> do
606+ compBody = brackets N $ located es $ \xs -> do
684607 let p_parBody =
685608 sep
686− (breakpoint >> txt "|" >> space)
609+ (breakpoint >> txt "| ")
687610 p_seqBody
688611 p_seqBody =
689612 sitcc
690613 . sep
691− commaDel
614+ (comma >> breakpoint)
692615 (located' (sitcc . p_stmt))
693616 stmts = init xs
694617 yield = last xs
@@ -709,94 +632,88 @@ p_hsExpr' s = \case
709632 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"
710633 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"
711634 ExplicitList _ _ xs ->
712− brackets s $
713− sep commaDel (sitcc . located' p_hsExpr) xs
635+ brackets s . sitcc $
636+ sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs
714637 RecordCon {..} -> do
715638 located rcon_con_name atom
716639 breakpoint
717640 let HsRecFields {..} = rcon_flds
718641 updName f =
719− (f :: HsRecField GhcPs (LHsExpr GhcPs))
642+ f
720643 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
721644 FieldOcc _ n -> n
722− XFieldOcc x -> noExtCon x
645+ XFieldOcc _ -> notImplemented "XFieldOcc"
723646 }
724647 fields = located' (p_hsRecField . updName) <$> rec_flds
725648 dotdot =
726649 case rec_dotdot of
727650 Just {} -> [txt ".."]
728651 Nothing -> []
729− inci . braces N $
730− sep commaDel sitcc (fields <> dotdot)
652+ inci . braces N . sitcc $
653+ sep (comma >> breakpoint) sitcc (fields <> dotdot)
731654 RecordUpd {..} -> do
732655 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
656+ breakpoint
741657 let updName f =
742− (f :: HsRecUpdField GhcPs)
658+ f
743659 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of
744660 Ambiguous _ n -> n
745661 Unambiguous _ n -> n
746− XAmbiguousFieldOcc x -> noExtCon x
662+ XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"
747663 }
748− inci . braces N $
664+ inci . braces N . sitcc $
749665 sep
750− commaDel
666+ (comma >> breakpoint)
751667 (sitcc . located' (p_hsRecField . updName))
752668 rupd_flds
753− ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do
669+ ExprWithTySig affix x -> sitcc $ do
754670 located x p_hsExpr
755671 space
756672 txt "::"
757673 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 ->
674+ inci $ do
675+ let HsWC {..} = affix
676+ HsIB {..} = hswc_body
677+ located hsib_body p_hsType
678+ ArithSeq NoExt _ x -> do
762679 case x of
763− From from -> brackets s $ do
680+ From from -> brackets s . sitcc $ do
764681 located from p_hsExpr
765682 breakpoint
766683 txt ".."
767− FromThen from next -> brackets s $ do
768− sep commaDel (located' p_hsExpr) [from, next]
684+ FromThen from next -> brackets s . sitcc $ do
685+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
769686 breakpoint
770687 txt ".."
771− FromTo from to -> brackets s $ do
688+ FromTo from to -> brackets s . sitcc $ do
772689 located from p_hsExpr
773690 breakpoint
774691 txt ".."
775692 space
776693 located to p_hsExpr
777− FromThenTo from next to -> brackets s $ do
778− sep commaDel (located' p_hsExpr) [from, next]
694+ FromThenTo from next to -> brackets s . sitcc $ do
695+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]
779696 breakpoint
780697 txt ".."
781698 space
782699 located to p_hsExpr
783− HsSCC NoExtField _ name x -> do
700+ HsSCC NoExt _ name x -> do
784701 txt "{-# SCC "
785702 atom name
786703 txt " #-}"
787704 breakpoint
788705 located x p_hsExpr
789− HsCoreAnn NoExtField _ value x -> do
706+ HsCoreAnn NoExt _ value x -> do
790707 txt "{-# CORE "
791708 atom value
792709 txt " #-}"
793710 breakpoint
794711 located x p_hsExpr
795− HsBracket NoExtField x -> p_hsBracket x
712+ HsBracket NoExt x -> p_hsBracket x
796713 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
797714 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
798− HsSpliceE NoExtField splice -> p_hsSplice splice
799− HsProc NoExtField p e -> do
715+ HsSpliceE NoExt splice -> p_hsSplice splice
716+ HsProc NoExt p e -> do
800717 txt "proc"
801718 located p $ \x -> do
802719 breakpoint
@@ -809,11 +726,31 @@ p_hsExpr' s = \case
809726 txt "static"
810727 breakpoint
811728 inci (located e p_hsExpr)
729+ HsArrApp NoExt body input arrType cond ->
730+ p_hsCmd (HsCmdArrApp NoExt body input arrType cond)
731+ HsArrForm NoExt form mfixity cmds ->
732+ p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)
812733 HsTick {} -> notImplemented "HsTick"
813734 HsBinTick {} -> notImplemented "HsBinTick"
814735 HsTickPragma {} -> notImplemented "HsTickPragma"
736+ -- These four constructs should never appear in correct programs.
737+ -- See: https://github.com/tweag/ormolu/issues/343
738+ EWildPat NoExt -> txt "_"
739+ EAsPat NoExt n p -> do
740+ p_rdrName n
741+ txt "@"
742+ located p p_hsExpr
743+ EViewPat NoExt p e -> do
744+ located p p_hsExpr
745+ space
746+ txt "->"
747+ breakpoint
748+ inci (located e p_hsExpr)
749+ ELazyPat NoExt p -> do
750+ txt "~"
751+ located p p_hsExpr
815752 HsWrap {} -> notImplemented "HsWrap"
816− XExpr x -> noExtCon x
753+ XExpr {} -> notImplemented "XExpr"
817754
818755p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()
819756p_patSynBind PSB {..} = do
@@ -825,7 +762,7 @@ p_patSynBind PSB {..} = do
825762 breakpoint
826763 located psb_def p_pat
827764 ImplicitBidirectional -> do
828− equals
765+ txt "="
829766 breakpoint
830767 located psb_def p_pat
831768 ExplicitBidirectional mgroup -> do
@@ -852,8 +789,8 @@ p_patSynBind PSB {..} = do
852789 inci $ do
853790 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do
854791 unless (null xs) breakpoint
855− braces N $
856− sep commaDel (p_rdrName . recordPatSynPatVar) xs
792+ braces N . sitcc $
793+ sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs
857794 rhs
858795 InfixCon l r -> do
859796 switchLayout [getLoc l, getLoc r] $ do
@@ -865,7 +802,7 @@ p_patSynBind PSB {..} = do
865802 space
866803 p_rdrName r
867804 inci rhs
868−p_patSynBind (XPatSynBind x) = noExtCon x
805+p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
869806
870807p_case ::
871808 Data body =>
@@ -876,7 +813,7 @@ p_case ::
876813 -- | Expression
877814 LHsExpr GhcPs ->
878815 -- | Match group
879− MatchGroup GhcPs (Located body) ->
816+ (MatchGroup GhcPs (Located body)) ->
880817 R ()
881818p_case placer render e mgroup = do
882819 txt "case"
@@ -907,12 +844,10 @@ p_if placer render if' then' else' = do
907844 breakpoint
908845 inci $ do
909846 txt "then"
910− space
911847 located then' $ \x ->
912848 placeHanging (placer x) (render x)
913849 breakpoint
914850 txt "else"
915− space
916851 located else' $ \x ->
917852 placeHanging (placer x) (render x)
918853
@@ -934,29 +869,29 @@ p_let render localBinds e = sitcc $ do
934869
935870p_pat :: Pat GhcPs -> R ()
936871p_pat = \case
937− WildPat NoExtField -> txt "_"
938− VarPat NoExtField name -> p_rdrName name
939− LazyPat NoExtField pat -> do
872+ WildPat NoExt -> txt "_"
873+ VarPat NoExt name -> p_rdrName name
874+ LazyPat NoExt pat -> do
940875 txt "~"
941876 located pat p_pat
942− AsPat NoExtField name pat -> do
877+ AsPat NoExt name pat -> do
943878 p_rdrName name
944879 txt "@"
945880 located pat p_pat
946− ParPat NoExtField pat ->
881+ ParPat NoExt pat ->
947882 located pat (parens S . p_pat)
948− BangPat NoExtField pat -> do
883+ BangPat NoExt pat -> do
949884 txt "!"
950885 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' =
886+ ListPat NoExt pats -> do
887+ brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats
888+ TuplePat NoExt pats boxing -> do
889+ let f =
955890 case boxing of
956891 Boxed -> parens S
957892 Unboxed -> parensHash S
958− parens' $ sep commaDel (sitcc . located' p_pat) pats
959− SumPat NoExtField pat tag arity ->
893+ f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats
894+ SumPat NoExt pat tag arity ->
960895 p_unboxedSum S tag arity (located pat p_pat)
961896 ConPatIn pat details ->
962897 case details of
@@ -971,40 +906,38 @@ p_pat = \case
971906 let f = \case
972907 Nothing -> txt ".."
973908 Just x -> located x p_pat_hsRecField
974− inci . braces N . sep commaDel f $
909+ inci . braces N . sitcc . sep (comma >> breakpoint) f $
975910 case dotdot of
976911 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
912+ Just n -> (Just <$> take n fields) ++ [Nothing]
913+ InfixCon x y -> do
914+ located x p_pat
915+ space
916+ p_rdrName pat
917+ breakpoint
918+ inci (located y p_pat)
986919 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?
987− ViewPat NoExtField expr pat -> sitcc $ do
920+ ViewPat NoExt expr pat -> sitcc $ do
988921 located expr p_hsExpr
989922 space
990923 txt "->"
991924 breakpoint
992925 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
926+ SplicePat NoExt splice -> p_hsSplice splice
927+ LitPat NoExt p -> atom p
928+ NPat NoExt v _ _ -> located v (atom . ol_val)
929+ NPlusKPat NoExt n k _ _ _ -> sitcc $ do
997930 p_rdrName n
998931 breakpoint
999932 inci $ do
1000933 txt "+"
1001934 space
1002935 located k (atom . ol_val)
1003− SigPat NoExtField pat hswc -> do
936+ SigPat hswc pat -> do
1004937 located pat p_pat
1005938 p_typeAscription hswc
1006939 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage
1007− XPat x -> noExtCon x
940+ XPat NoExt -> notImplemented "XPat"
1008941
1009942p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()
1010943p_pat_hsRecField HsRecField {..} = do
@@ -1012,7 +945,7 @@ p_pat_hsRecField HsRecField {..} = do
1012945 p_rdrName (rdrNameFieldOcc x)
1013946 unless hsRecPun $ do
1014947 space
1015− equals
948+ txt "="
1016949 breakpoint
1017950 inci (located hsRecFieldArg p_pat)
1018951
@@ -1021,31 +954,32 @@ p_unboxedSum s tag arity m = do
1021954 let before = tag - 1
1022955 after = arity - before - 1
1023956 args = replicate before Nothing <> [Just m] <> replicate after Nothing
1024− f x =
957+ f (x, i) = do
958+ let isFirst = i == 0
959+ isLast = i == arity - 1
1025960 case x :: Maybe (R ()) of
1026961 Nothing ->
1027− space
962+ unless (isFirst || isLast) space
1028963 Just m' -> do
1029− space
964+ unless isFirst space
1030965 m'
1031− space
1032− parensHash s $ sep (txt "|") f args
966+ unless isLast space
967+ parensHash s $ sep (txt "|") f (zip args [0 ..])
1033968
1034969p_hsSplice :: HsSplice GhcPs -> R ()
1035970p_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
971+ HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
972+ HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
973+ HsQuasiQuote NoExt _ quoterName srcSpan str -> do
1039974 txt "["
1040975 p_rdrName (L srcSpan quoterName)
1041976 txt "|"
1042− -- QuasiQuoters often rely on precise custom strings. We cannot do any
1043− -- formatting here without potentially breaking someone's code.
977+ -- NOTE QuasiQuoters often rely on precise custom strings. We cannot do
978+ -- any formatting here without potentially breaking someone's code.
1044979 atom str
1045980 txt "|]"
1046981 HsSpliced {} -> notImplemented "HsSpliced"
1047− HsSplicedT {} -> notImplemented "HsSplicedT"
1048− XSplice x -> noExtCon x
982+ XSplice {} -> notImplemented "XSplice"
1049983
1050984p_hsSpliceTH ::
1051985 -- | Typed splice?
@@ -1069,17 +1003,17 @@ p_hsSpliceTH isTyped expr = \case
10691003
10701004p_hsBracket :: HsBracket GhcPs -> R ()
10711005p_hsBracket = \case
1072− ExpBr NoExtField expr -> do
1006+ ExpBr NoExt expr -> do
10731007 anns <- getEnclosingAnns
10741008 let name = case anns of
10751009 AnnOpenEQ : _ -> ""
10761010 _ -> "e"
10771011 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
1012+ PatBr NoExt pat -> quote "p" (located pat p_pat)
1013+ DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)
1014+ DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
1015+ TypBr NoExt ty -> quote "t" (located ty p_hsType)
1016+ VarBr NoExt isSingleQuote name -> do
10831017 txt (bool "''" "'" isSingleQuote)
10841018 -- HACK As you can see we use 'noLoc' here to be able to pass name into
10851019 -- 'p_rdrName' since the latter expects a "located" thing. The problem
@@ -1094,13 +1028,13 @@ p_hsBracket = \case
10941028 && not (doesNotNeedExtraParens name)
10951029 wrapper = if isOperator then parens N else id
10961030 wrapper $ p_rdrName (noLoc name)
1097− TExpBr NoExtField expr -> do
1031+ TExpBr NoExt expr -> do
10981032 txt "[||"
10991033 breakpoint'
11001034 located expr p_hsExpr
11011035 breakpoint'
11021036 txt "||]"
1103− XBracket x -> noExtCon x
1037+ XBracket {} -> notImplemented "XBracket"
11041038 where
11051039 quote :: Text -> R () -> R ()
11061040 quote name body = do
@@ -1154,8 +1088,7 @@ p_stringLit src =
11541088 zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]
11551089 zipPrevNext xs =
11561090 let z =
1157− zip
1158− (zip (Nothing : map Just xs) xs)
1091+ zip (zip (Nothing : map Just xs) xs)
11591092 (map Just (tail xs) ++ repeat Nothing)
11601093 in map (\((p, x), n) -> (p, x, n)) z
11611094 orig (_, x, _) = x
@@ -1179,9 +1112,9 @@ liftAppend (x : xs) [] = x : xs
11791112liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys
11801113
11811114getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan
1182−getGRHSSpan (GRHS NoExtField guards body) =
1115+getGRHSSpan (GRHS NoExt guards body) =
11831116 combineSrcSpans' $ getLoc body :| map getLoc guards
1184−getGRHSSpan (XGRHS x) = noExtCon x
1117+getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"
11851118
11861119-- | Place a thing that may have a hanging form. This function handles how
11871120-- to separate it from preceding expressions and whether to bump indentation
@@ -1202,44 +1135,46 @@ blockPlacement ::
12021135 (body -> Placement) ->
12031136 [LGRHS GhcPs (Located body)] ->
12041137 Placement
1205−blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x
1138+blockPlacement placer [(L _ (GRHS NoExt _ (L _ x)))] = placer x
12061139blockPlacement _ _ = Normal
12071140
12081141-- | Check if given command has a hanging form.
12091142cmdPlacement :: HsCmd GhcPs -> Placement
12101143cmdPlacement = \case
1211− HsCmdLam NoExtField _ -> Hanging
1212− HsCmdCase NoExtField _ _ -> Hanging
1213− HsCmdDo NoExtField _ -> Hanging
1144+ HsCmdLam NoExt _ -> Hanging
1145+ HsCmdCase NoExt _ _ -> Hanging
1146+ HsCmdDo NoExt _ -> Hanging
12141147 _ -> Normal
12151148
12161149cmdTopPlacement :: HsCmdTop GhcPs -> Placement
12171150cmdTopPlacement = \case
1218− HsCmdTop NoExtField (L _ x) -> cmdPlacement x
1219− XCmdTop x -> noExtCon x
1151+ HsCmdTop NoExt (L _ x) -> cmdPlacement x
1152+ XCmdTop {} -> notImplemented "XCmdTop"
12201153
12211154-- | Check if given expression has a hanging form.
12221155exprPlacement :: HsExpr GhcPs -> Placement
12231156exprPlacement = \case
12241157 -- Only hang lambdas with single line parameter lists
1225− HsLam NoExtField mg -> case mg of
1226− MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _
1158+ HsLam NoExt mg -> case mg of
1159+ MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _
12271160 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->
12281161 Hanging
12291162 _ -> 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 _ ->
1163+ HsLamCase NoExt _ -> Hanging
1164+ HsCase NoExt _ _ -> Hanging
1165+ HsDo NoExt DoExpr _ -> Hanging
1166+ HsDo NoExt MDoExpr _ -> Hanging
1167+ RecordCon NoExt _ _ -> Hanging
1168+ -- If the rightmost expression in an operator chain is hanging, make the
1169+ -- whole block hanging; so that we can use the common @f = foo $ do@
1170+ -- style.
1171+ OpApp NoExt _ _ y -> exprPlacement (unLoc y)
1172+ -- Same thing for function applications (usually with -XBlockArguments)
1173+ HsApp NoExt _ y -> exprPlacement (unLoc y)
1174+ HsProc NoExt (L s _) _ ->
12401175 -- Indentation breaks if pattern is longer than one line and left
12411176 -- hanging. Consequently, only apply hanging when it is safe.
1242− if isOneLineSpan (getLoc p)
1177+ if isOneLineSpan s
12431178 then Hanging
12441179 else Normal
12451180 _ -> Normal
@@ -1248,31 +1183,30 @@ withGuards :: [LGRHS GhcPs (Located body)] -> Bool
12481183withGuards = any (checkOne . unLoc)
12491184 where
12501185 checkOne :: GRHS GhcPs (Located body) -> Bool
1251− checkOne (GRHS NoExtField [] _) = False
1186+ checkOne (GRHS NoExt [] _) = False
12521187 checkOne _ = True
12531188
12541189exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)
1255−exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
1190+exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)
12561191exprOpTree n = OpNode n
12571192
12581193getOpName :: HsExpr GhcPs -> Maybe RdrName
12591194getOpName = \case
1260− HsVar NoExtField (L _ a) -> Just a
1195+ HsVar NoExt (L _ a) -> Just a
12611196 _ -> Nothing
12621197
1263−getOpNameStr :: RdrName -> String
1264−getOpNameStr = occNameString . rdrNameOcc
1265−
12661198p_exprOpTree ::
1199+ -- | Can use special handling of dollar?
1200+ Bool ->
12671201 -- | Bracket style to use
12681202 BracketStyle ->
12691203 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
12701204 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.
1205+p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
1206+p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
1207+ -- NOTE If the beginning of the first argument and the second argument
1208+ -- are on the same line, and the second argument has a hanging form, use
1209+ -- hanging placement.
12761210 let placement =
12771211 if isOneLineSpan
12781212 (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y)))
@@ -1280,10 +1214,8 @@ p_exprOpTree s (OpBranch x op y) = do
12801214 OpNode (L _ n) -> exprPlacement n
12811215 _ -> Normal
12821216 else Normal
1283− -- Distinguish holes used in infix notation.
1284− -- eg. '1 _foo 2' and '1 `_foo` 2'
12851217 opWrapper = case unLoc op of
1286− HsUnboundVar NoExtField _ -> backticks
1218+ EWildPat NoExt -> backticks
12871219 _ -> id
12881220 layout <- getLayout
12891221 let ub = case layout of
@@ -1291,67 +1223,24 @@ p_exprOpTree s (OpBranch x op y) = do
12911223 MultiLine -> case placement of
12921224 Hanging -> useBraces
12931225 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
1226+ gotDollar = case getOpName (unLoc op) of
1227+ Just rname -> mkVarOcc "$" == (rdrNameOcc rname)
13091228 _ -> 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
1229+ switchLayout [opTreeLoc x]
1230+ $ ub
1231+ $ p_exprOpTree (not gotDollar) s x
1232+ let p_op = located op (opWrapper . p_hsExpr)
1233+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
1234+ if isDollarSpecial && gotDollar && placement == Normal && isOneLineSpan (opTreeLoc x)
1235+ then do
1236+ space
1237+ p_op
1238+ breakpoint
1239+ inci p_y
1240+ else placeHanging placement $ do
1241+ p_op
1242+ space
1243+ p_y
13551244
13561245-- | Get annotations for the enclosing element.
13571246getEnclosingAnns :: 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+17−38
@@ -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,53 +20,35 @@ 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
34+ forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
5335 case hsmodName of
5436 Nothing -> return ()
5537 Just hsmodName' -> do
56− located hsmodName' $ \name -> do
57− forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)
58− p_hsmodName name
59− breakpoint
38+ located hsmodName' p_hsmodName
6039 forM_ hsmodDeprecMessage $ \w -> do
61− located' p_moduleWarning w
6240 breakpoint
41+ located' p_moduleWarning w
6342 case hsmodExports of
6443 Nothing -> return ()
65− Just l -> do
66− located l $ \exports -> do
67− inci (p_hsmodExports exports)
44+ Just hsmodExports' -> do
6845 breakpoint
46+ inci (p_hsmodExports (unLoc hsmodExports'))
47+ breakpoint
6948 txt "where"
7049 newline
7150 newline
72− forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))
51+ forM_ (sortImports hsmodImports) (located' p_hsmodImport)
7352 newline
7453 switchLayout (getLoc <$> hsmodDecls) $ do
7554 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+81−123
@@ -5,18 +5,16 @@
55-- | Rendering of types.
66module Ormolu.Printer.Meat.Type
77 ( p_hsType,
8− p_hsTypePostDoc,
98 hasDocStrings,
109 p_hsContext,
1110 p_hsTyVarBndr,
12− p_forallBndrs,
1311 p_conDeclFields,
1412 tyVarsToTypes,
1513 )
1614where
1715
18−import Data.Data (Data)
19−import GHC hiding (isPromoted)
16+import BasicTypes
17+import GHC
2018import Ormolu.Printer.Combinators
2119import Ormolu.Printer.Meat.Common
2220import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
@@ -24,23 +22,17 @@ import Ormolu.Printer.Operators
2422import Ormolu.Utils
2523
2624p_hsType :: HsType GhcPs -> R ()
27−p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t
28−
29−p_hsTypePostDoc :: HsType GhcPs -> R ()
30−p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t
31−
32−-- | How to render Haddocks associated with a type.
33−data TypeDocStyle
34− = PipeStyle
35− | CaretStyle
36−
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
25+p_hsType t = p_hsType' (hasDocStrings t) t
26+
27+p_hsType' :: Bool -> HsType GhcPs -> R ()
28+p_hsType' multilineArgs = \case
29+ HsForAllTy NoExt bndrs t -> do
30+ txt "forall "
31+ sep space (located' p_hsTyVarBndr) bndrs
32+ txt "."
4133 interArgBreak
42− p_hsTypeR (unLoc t)
43− HsQualTy NoExtField qs t -> do
34+ p_hsType' multilineArgs (unLoc t)
35+ HsQualTy NoExt qs t -> do
4436 located qs p_hsContext
4537 space
4638 txt "=>"
@@ -49,39 +41,20 @@ p_hsType' multilineArgs docStyle = \case
4941 HsQualTy {} -> p_hsTypeR (unLoc t)
5042 HsFunTy {} -> p_hsTypeR (unLoc t)
5143 _ -> located t p_hsTypeR
52− HsTyVar NoExtField p n -> do
44+ HsTyVar NoExt p n -> do
5345 case p of
54− IsPromoted -> do
46+ Promoted -> do
5547 txt "'"
5648 case showOutputable (unLoc n) of
5749 _ : '\'' : _ -> space
5850 _ -> return ()
5951 NotPromoted -> return ()
6052 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
75− HsAppKindTy _ ty kd -> sitcc $ do
76− -- The first argument is the location of the "@..." part. Not 100% sure,
77− -- but I think we can ignore it as long as we use 'located' on both the
78− -- type and the kind.
79− located ty p_hsType
53+ HsAppTy NoExt f x -> sitcc $ do
54+ located f p_hsType
8055 breakpoint
81− inci $ do
82− txt "@"
83− located kd p_hsType
84− HsFunTy NoExtField x y@(L _ y') -> do
56+ inci (located x p_hsType)
57+ HsFunTy NoExt x y@(L _ y') -> do
8558 located x p_hsType
8659 space
8760 txt "->"
@@ -89,49 +62,51 @@ p_hsType' multilineArgs docStyle = \case
8962 case y' of
9063 HsFunTy {} -> p_hsTypeR y'
9164 _ -> located y p_hsTypeR
92− HsListTy NoExtField t ->
65+ HsListTy NoExt t ->
9366 located t (brackets N . p_hsType)
94− HsTupleTy NoExtField tsort xs ->
67+ HsTupleTy NoExt tsort xs ->
9568 let parens' =
9669 case tsort of
9770 HsUnboxedTuple -> parensHash N
9871 HsBoxedTuple -> parens N
9972 HsConstraintTuple -> parens N
10073 HsBoxedOrConstraintTuple -> parens N
101− in parens' $ sep commaDel (sitcc . located' p_hsType) xs
102− HsSumTy NoExtField xs ->
103− parensHash N $
74+ in parens' . sitcc $
75+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs
76+ HsSumTy NoExt xs ->
77+ parensHash N . sitcc $
10478 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 ->
79+ HsOpTy NoExt x op y -> sitcc $ do
80+ let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
81+ in p_tyOpTree (reassociateOpTree Just opTree)
82+ HsParTy NoExt (L _ t@HsKindSig {}) ->
83+ -- NOTE Kind signatures already put parentheses around in all cases, so
84+ -- skip this layer of parentheses. The reason for this behavior is that
85+ -- parentheses are not always encoded with 'HsParTy', but seem to be
86+ -- always necessary when we have kind signatures in place.
87+ p_hsType t
88+ HsParTy NoExt t ->
11089 parens N (located t p_hsType)
111− HsIParamTy NoExtField n t -> sitcc $ do
90+ HsIParamTy NoExt n t -> sitcc $ do
11291 located n atom
11392 space
11493 txt "::"
11594 breakpoint
11695 inci (located t p_hsType)
117− HsStarTy NoExtField _ -> txt "*"
118− HsKindSig NoExtField t k -> sitcc $ do
96+ HsStarTy NoExt _ -> txt "*"
97+ HsKindSig NoExt t k ->
98+ -- NOTE Also see the comment for 'HsParTy'.
99+ parens N . sitcc $ do
100+ located t p_hsType
101+ space -- FIXME
102+ txt "::"
103+ space
104+ inci (located k p_hsType)
105+ HsSpliceTy NoExt splice -> p_hsSplice splice
106+ HsDocTy NoExt t str -> do
107+ p_hsDocString Pipe True str
119108 located t p_hsType
120− space
121− txt "::"
122− breakpoint
123− inci (located k p_hsType)
124− HsSpliceTy NoExtField splice -> p_hsSplice splice
125− HsDocTy NoExtField t str ->
126− case docStyle of
127− PipeStyle -> do
128− p_hsDocString Pipe True str
129− located t p_hsType
130− CaretStyle -> do
131− located t p_hsType
132− newline
133− p_hsDocString Caret False str
134− HsBangTy NoExtField (HsSrcBang _ u s) t -> do
109+ HsBangTy NoExt (HsSrcBang _ u s) t -> do
135110 case u of
136111 SrcUnpack -> txt "{-# UNPACK #-}" >> space
137112 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
@@ -141,49 +116,49 @@ 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
148− IsPromoted -> txt "'"
123+ Promoted -> txt "'"
149124 NotPromoted -> return ()
150125 brackets N $ do
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+ (Promoted, ((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
172− HsTyVar _ IsPromoted _ -> True
173− HsExplicitTupleTy {} -> True
174− HsExplicitListTy {} -> True
147+ HsTyVar _ Promoted _ -> 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,49 @@ 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
207−
208−-- | Render several @forall@-ed variables.
209−p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()
210−p_forallBndrs ForallInvis _ [] = txt "forall."
211−p_forallBndrs ForallVis _ [] = txt "forall ->"
212−p_forallBndrs vis p tyvars =
213− switchLayout (getLoc <$> tyvars) $ do
214− txt "forall"
215− breakpoint
216− inci $ do
217− sitcc $ sep breakpoint (sitcc . located' p) tyvars
218− case vis of
219− ForallInvis -> txt "."
220− ForallVis -> space >> txt "->"
183+ XTyVarBndr NoExt -> notImplemented "XTyVarBndr"
221184
222185p_conDeclFields :: [LConDeclField GhcPs] -> R ()
223186p_conDeclFields xs =
224− braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
187+ braces N . sitcc $
188+ sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs
225189
226190p_conDeclField :: ConDeclField GhcPs -> R ()
227191p_conDeclField ConDeclField {..} = do
228192 mapM_ (p_hsDocString Pipe True) cd_fld_doc
229193 sitcc $
230− sep
231− commaDel
194+ sep (comma >> breakpoint)
232195 (located' (p_rdrName . rdrNameFieldOcc))
233196 cd_fld_names
234197 space
235198 txt "::"
236199 breakpoint
237200 sitcc . inci $ p_hsType (unLoc cd_fld_type)
238−p_conDeclField (XConDeclField x) = noExtCon x
201+p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"
239202
240203tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)
241−tyOpTree (L _ (HsOpTy NoExtField l op r)) =
204+tyOpTree (L _ (HsOpTy NoExt l op r)) =
242205 OpBranch (tyOpTree l) op (tyOpTree r)
243206tyOpTree n = OpNode n
244207
245208p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R ()
246209p_tyOpTree (OpNode n) = located n p_hsType
247210p_tyOpTree (OpBranch l op r) = do
248− switchLayout [opTreeLoc l] $
211+ switchLayout [opTreeLoc l] $ do
249212 p_tyOpTree l
250213 breakpoint
251214 inci . switchLayout [opTreeLoc r] $ do
@@ -259,17 +222,12 @@ p_tyOpTree (OpBranch l op r) = do
259222tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]
260223tyVarsToTypes = \case
261224 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit
262− XLHsQTyVars x -> noExtCon x
225+ XLHsQTyVars {} -> notImplemented "XLHsQTyVars"
263226
264227tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs
265228tyVarToType = \case
266− UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar
267− KindedTyVar NoExtField tvar kind ->
268− -- Note: we always add parentheses because for whatever reason GHC does
269− -- not use HsParTy for left-hand sides of declarations. Please see
270− -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
271− -- long as 'tyVarToType' does not get applied to right-hand sides of
272− -- declarations.
273− HsParTy NoExtField . noLoc $
274− HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
275− XTyVarBndr x -> noExtCon x
229+ UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar
230+ KindedTyVar NoExt tvar kind ->
231+ HsParTy NoExt $ noLoc $
232+ HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind
233+ 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+10−91
@@ -1,66 +1,40 @@
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,
13− typeArgToType,
14− unSrcSpan,
15− incSpanLine,
16− separatedByBlank,
17− separatedByBlankNE,
18− onTheSameLine,
19− removeIndentation,
2011 )
2112where
2213
23−import Data.Char (isSpace)
14+import Data.Data (Data, showConstr, toConstr)
2415import Data.List (dropWhileEnd)
2516import Data.List.NonEmpty (NonEmpty (..))
26−import qualified Data.List.NonEmpty as NE
27−import Data.Maybe (fromMaybe)
2817import Data.Text (Text)
2918import qualified Data.Text as T
30−import GHC
31−import GHC.DynFlags (baseDynFlags)
19+import HsDoc (HsDocString, unpackHDS)
3220import qualified Outputable as GHC
33−
34−-- | Relative positions in a list.
35−data RelativePos
36− = SinglePos
37− | FirstPos
38− | MiddlePos
39− | LastPos
40− deriving (Eq, Show)
41−
42−-- | Attach 'RelativePos'es to elements of a given list.
43−attachRelativePos :: [a] -> [(RelativePos, a)]
44−attachRelativePos = \case
45− [] -> []
46− [x] -> [(SinglePos, x)]
47− (x : xs) -> (FirstPos, x) : markLast xs
48− where
49− markLast [] = []
50− markLast [x] = [(LastPos, x)]
51− markLast (x : xs) = (MiddlePos, x) : markLast xs
21+import SrcLoc
5222
5323-- | Combine all source spans from the given list.
5424combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan
5525combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs
5626
27+-- | Return 'True' if given element of AST is module.
28+isModule :: Data a => a -> Bool
29+isModule x = showConstr (toConstr x) == "HsModule"
30+
5731-- | Placeholder for things that are not yet implemented.
5832notImplemented :: String -> a
5933notImplemented msg = error $ "not implemented yet: " ++ msg
6034
6135-- | Pretty-print an 'GHC.Outputable' thing.
6236showOutputable :: GHC.Outputable o => o -> String
63−showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr
37+showOutputable = GHC.showSDocUnsafe . GHC.ppr
6438
6539-- | Split and normalize a doc string. The result is a list of lines that
6640-- make up the comment.
@@ -98,58 +72,3 @@ splitDocString docStr =
9872 in if leadingSpace x
9973 then dropSpace <$> xs
10074 else xs
101−
102−-- | Get 'LHsType' out of 'LHsTypeArg'.
103−typeArgToType :: LHsTypeArg p -> LHsType p
104−typeArgToType = \case
105− HsValArg tm -> tm
106− HsTypeArg _ ty -> ty
107− HsArgPar _ -> notImplemented "HsArgPar"
108−
109−-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.
110−unSrcSpan :: SrcSpan -> Maybe RealSrcSpan
111−unSrcSpan = \case
112− RealSrcSpan r -> Just r
113− UnhelpfulSpan _ -> Nothing
114−
115−-- | Increment line number in a 'SrcSpan'.
116−incSpanLine :: Int -> SrcSpan -> SrcSpan
117−incSpanLine i = \case
118− RealSrcSpan s ->
119− let start = realSrcSpanStart s
120− end = realSrcSpanEnd s
121− incLine x =
122− let file = srcLocFile x
123− line = srcLocLine x
124− col = srcLocCol x
125− in mkRealSrcLoc file (line + i) col
126− in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end))
127− UnhelpfulSpan x -> UnhelpfulSpan x
128−
129−-- | Do two declarations have a blank between them?
130−separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool
131−separatedByBlank loc a b =
132− fromMaybe False $ do
133− endA <- srcSpanEndLine <$> unSrcSpan (loc a)
134− startB <- srcSpanStartLine <$> unSrcSpan (loc b)
135− pure (startB - endA >= 2)
136−
137−-- | Do two declaration groups have a blank between them?
138−separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool
139−separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)
140−
141−-- | Return 'True' if one span ends on the same line the second one starts.
142−onTheSameLine :: SrcSpan -> SrcSpan -> Bool
143−onTheSameLine a b =
144− isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))
145−
146−-- | Remove indentation from a given 'String'. Return the input with
147−-- indentation removed and the detected indentation level.
148−removeIndentation :: String -> (String, Int)
149−removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)
150− where
151− n = minimum (getIndent <$> xs)
152− getIndent y =
153− if all isSpace y
154− then 0
155− else length (takeWhile isSpace y)
tests/Ormolu/Parser/PragmaSpec.hs+1−1
@@ -4,7 +4,7 @@ import Ormolu.Parser.Pragma
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