From f1569c0454fa0b7243a9787746e7bdf7e8ae5879 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 27 Jun 2020 12:37:25 +0200 Subject: Bump stack.yaml --- stack.yaml | 5 +---- stack.yaml.lock | 29 ++++------------------------- 2 files changed, 5 insertions(+), 29 deletions(-) diff --git a/stack.yaml b/stack.yaml index b7c37af..723d5d8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,6 @@ -resolver: lts-14.20 +resolver: lts-15.6 packages: - '.' extra-deps: -- 'Cabal-3.0.0.0' - 'haskell-src-exts-1.23.0' -- 'HsYAML-0.2.1.0' -- 'HsYAML-aeson-0.2.0.0' diff --git a/stack.yaml.lock b/stack.yaml.lock index bc43b4e..450a155 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,13 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - hackage: Cabal-3.0.0.0@sha256:1ba37b8d80e89213b17db7b8b9ea0108da55ca65f8c0cbb7433881a284c5cf67,26027 - pantry-tree: - size: 71616 - sha256: 4f16f0a65304ab22f01cb7f6d25db2f15a168f4cefacde7864cb1e02eb3ea867 - original: - hackage: Cabal-3.0.0.0 - completed: hackage: haskell-src-exts-1.23.0@sha256:1bb9f7e97d569e56973133cb075fdcc1bfd11f90d94b035b5cf44814bb39a73d,4541 pantry-tree: @@ -18,23 +11,9 @@ packages: sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 original: hackage: haskell-src-exts-1.23.0 -- completed: - hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311 - pantry-tree: - size: 1340 - sha256: 21f61bf9cad31674126b106071dd9b852e408796aeffc90eec1792f784107eff - original: - hackage: HsYAML-0.2.1.0 -- completed: - hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791 - pantry-tree: - size: 234 - sha256: 67cc9ba17c79e71d3abdb465a3ee2825477856fff3b8b7d543cbbbefdae9a9d9 - original: - hackage: HsYAML-aeson-0.2.0.0 snapshots: - completed: - size: 524154 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/20.yaml - sha256: 2f5099f69ddb6abfe64400fe1e6a604e8e628f55e6837211cd70a81eb0a8fa4d - original: lts-14.20 + size: 491387 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/6.yaml + sha256: 8d81505a6de861e167a58534ab62330afb75bfa108735c7db1204f7ef2a39d79 + original: lts-15.6 -- cgit v1.2.3 From ce6ddb0fbdcf271595e51e33106231a7390665be Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 2 Aug 2020 13:09:59 +0100 Subject: Bump aeson bound to < 1.6 --- stylish-haskell.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8e9dffd..8ac2bf0 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -52,7 +52,7 @@ Library Paths_stylish_haskell Build-depends: - aeson >= 0.6 && < 1.5, + aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, Cabal >= 2.4 && < 3.1, @@ -78,7 +78,7 @@ Executable stylish-haskell strict >= 0.3 && < 0.4, optparse-applicative >= 0.12 && < 0.16, -- Copied from regular dependencies... - aeson >= 0.6 && < 1.5, + aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, Cabal >= 2.4 && < 3.1, @@ -138,7 +138,7 @@ Test-suite stylish-haskell-tests test-framework-hunit >= 0.2 && < 0.4, random >= 1.1, -- Copied from regular dependencies... - aeson >= 0.6 && < 1.5, + aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, Cabal >= 2.4 && < 3.1, -- cgit v1.2.3 From 2dd6fbd669e3501d5d4783dfa2d9f9ba3026ea1b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:24:49 +0200 Subject: Bump Cabal upper bound to 3.3 --- stack.yaml | 5 +++++ stack.yaml.lock | 35 +++++++++++++++++++++++++++++++++++ stylish-haskell.cabal | 4 ++-- 3 files changed, 42 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 723d5d8..8d1ed68 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,3 +4,8 @@ packages: extra-deps: - 'haskell-src-exts-1.23.0' +- 'aeson-1.5.2.0' +- 'Cabal-3.2.0.0' +- 'HsYAML-aeson-0.2.0.0@rev:2' +- 'HsYAML-0.2.1.0@rev:1' +- 'these-1.1.1.1' diff --git a/stack.yaml.lock b/stack.yaml.lock index 450a155..685b590 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,41 @@ packages: sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 original: hackage: haskell-src-exts-1.23.0 +- completed: + hackage: aeson-1.5.2.0@sha256:d00c7aa51969b2849550e4dee14c9ce188504d55ed8d7f734ce9f6976db452f6,6786 + pantry-tree: + size: 39758 + sha256: 992b01282d72e4db664289db69a846a4ec675379ca96824ba902a7541104d409 + original: + hackage: aeson-1.5.2.0 +- completed: + hackage: Cabal-3.2.0.0@sha256:d0d7a1f405f25d0000f5ddef684838bc264842304fd4e7f80ca92b997b710874,27320 + pantry-tree: + size: 40963 + sha256: b122f2d76dc82a350d3986fa0cbc4ecf9c3bb4f9c598ccbfb3b2bfdde02f3698 + original: + hackage: Cabal-3.2.0.0 +- completed: + hackage: HsYAML-aeson-0.2.0.0@sha256:b58e8587d480f8c29e4cb4f61ad6ab5d74195d31340e6e8c317ac4d13b65c469,1861 + pantry-tree: + size: 234 + sha256: 8a181cdb027e2862fd54cb47d0ff91a45126ab4cd2080083128e800c5fa2635b + original: + hackage: HsYAML-aeson-0.2.0.0@rev:2 +- completed: + hackage: HsYAML-0.2.1.0@sha256:6e63cbc919543c5a837040f063e96fe0a4e43bef8ab3c057cef8f122396fdc2d,5469 + pantry-tree: + size: 1340 + sha256: 77d9299977dfbc7836cbbcb51fe890bb70d485d9dd89a3bbe54822635faa8108 + original: + hackage: HsYAML-0.2.1.0@rev:1 +- completed: + hackage: these-1.1.1.1@sha256:3b63a3942f1da4ff97786221e3c654b969b54d570fef2cf4db97da4ea26a36cc,2609 + pantry-tree: + size: 351 + sha256: 9dbf8c39e2962926d5fb2c7bffba5e3407fed67a581ef60e2eaf3cb0c5778074 + original: + hackage: these-1.1.1.1 snapshots: - completed: size: 491387 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8ac2bf0..ccae6aa 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -55,7 +55,7 @@ Library aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.1, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, @@ -81,7 +81,7 @@ Executable stylish-haskell aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.1, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, -- cgit v1.2.3 From 7c4fa9de2accb0a617a8a930df3655086eed147b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:26:21 +0200 Subject: Bump version to 0.11.0.1 --- .circleci/config.yml | 2 +- CHANGELOG | 4 ++++ stylish-haskell.cabal | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index e1e9020..c8c1def 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -12,7 +12,7 @@ workflows: jobs: build: docker: - - image: 'haskell:8.6' + - image: 'haskell:8.8' steps: - checkout diff --git a/CHANGELOG b/CHANGELOG index fe2cc55..fc88a93 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # CHANGELOG +- 0.11.0.1 + * Bump `aeson` upper bound to 1.6 + * Bump `Cabal` upper bound to 3.3 + - 0.11.0.0 (2020-02-24) * Disable record formatting by default * Allow more customization for record formatting (by Maxim Koltsov) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index ccae6aa..f7f22e1 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.11.0.0 +Version: 0.11.0.1 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 -- cgit v1.2.3 From 1e2496d8c385db37de26f1bec36fc6bbb12d1885 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:27:13 +0200 Subject: Bump CHANGELOG --- CHANGELOG | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index fc88a93..bcfbd31 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,6 @@ # CHANGELOG -- 0.11.0.1 +- 0.11.0.1 (2020-08-02) * Bump `aeson` upper bound to 1.6 * Bump `Cabal` upper bound to 3.3 -- cgit v1.2.3 From a6af31005d1cd2584094795ce6483461d40511a9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:28:41 +0200 Subject: Bump Cabal-version to 1.10 --- stack.yaml | 2 ++ stylish-haskell.cabal | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 8d1ed68..a52bc65 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,3 +9,5 @@ extra-deps: - 'HsYAML-aeson-0.2.0.0@rev:2' - 'HsYAML-0.2.1.0@rev:1' - 'these-1.1.1.1' + +save-hackage-creds: false diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index f7f22e1..07dfca7 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -9,7 +9,7 @@ Maintainer: Jasper Van der Jeugt Copyright: 2012 Jasper Van der Jeugt Category: Language Build-type: Simple -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 Description: A Haskell code prettifier. For more information, see: -- cgit v1.2.3 From 736b55605da51919bfea07028c077c1a426375ec Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:29:50 +0200 Subject: Bump version to 0.11.0.2 --- CHANGELOG | 3 +++ stylish-haskell.cabal | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index bcfbd31..79487a0 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,8 @@ # CHANGELOG +- 0.11.0.2 (2020-08-02) + * Bump `Cabal-version` to 1.10 + - 0.11.0.1 (2020-08-02) * Bump `aeson` upper bound to 1.6 * Bump `Cabal` upper bound to 3.3 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 07dfca7..4b88958 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.11.0.1 +Version: 0.11.0.2 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 -- cgit v1.2.3 From b2742ad8ebe8082d01bb26eb84768e6e5af4f88a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:32:25 +0200 Subject: Set default-language as Haskell2010 --- stylish-haskell.cabal | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 4b88958..fa779a0 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -24,8 +24,9 @@ Extra-source-files: data/stylish-haskell.yaml Library - Hs-source-dirs: lib - Ghc-options: -Wall + Hs-source-dirs: lib + Ghc-options: -Wall + Default-language: Haskell2010 Exposed-modules: Language.Haskell.Stylish @@ -69,9 +70,10 @@ Library HsYAML >=0.2.0 && < 0.3 Executable stylish-haskell - Ghc-options: -Wall - Hs-source-dirs: src - Main-is: Main.hs + Ghc-options: -Wall + Hs-source-dirs: src + Main-is: Main.hs + Default-language: Haskell2010 Build-depends: stylish-haskell, @@ -93,10 +95,11 @@ Executable stylish-haskell HsYAML >=0.2.0 && < 0.3 Test-suite stylish-haskell-tests - Ghc-options: -Wall - Hs-source-dirs: tests lib - Main-is: TestSuite.hs - Type: exitcode-stdio-1.0 + Ghc-options: -Wall + Hs-source-dirs: tests lib + Main-is: TestSuite.hs + Type: exitcode-stdio-1.0 + Default-language: Haskell2010 Other-modules: Language.Haskell.Stylish -- cgit v1.2.3 From 771b82f3c4af465a2f2b675ca9a28d18d3a27c1b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 2 Aug 2020 14:33:19 +0200 Subject: Bump version to 0.11.0.3 --- CHANGELOG | 3 +++ stylish-haskell.cabal | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 79487a0..56faa64 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,8 @@ # CHANGELOG +- 0.11.0.3 (2020-08-02) + * Set default-language to Haskell2010 + - 0.11.0.2 (2020-08-02) * Bump `Cabal-version` to 1.10 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index fa779a0..4030547 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.11.0.2 +Version: 0.11.0.3 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 -- cgit v1.2.3 From 9550aa1cd177aa6fe271d075177109d66a79e67f Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Thu, 6 Aug 2020 23:50:35 +0800 Subject: Allow Cabal 3.2 for test suite The bounds of Cabal were not updated in 2dd6fbd669e3501d5d4783dfa2d9f9ba3026ea1b --- stylish-haskell.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 4030547..8823918 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -144,7 +144,7 @@ Test-suite stylish-haskell-tests aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.1, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, -- cgit v1.2.3 From e61c51c67c0ec44d9a3bff4d68666041bf550e58 Mon Sep 17 00:00:00 2001 From: Colin Woodbury Date: Mon, 17 Aug 2020 11:07:37 -0700 Subject: Use `-split-sections` --- stack.yaml | 12 +++++++----- stack.yaml.lock | 22 ++++------------------ 2 files changed, 11 insertions(+), 23 deletions(-) diff --git a/stack.yaml b/stack.yaml index a52bc65..59f2be5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,13 +1,15 @@ -resolver: lts-15.6 -packages: -- '.' +resolver: lts-16.9 + +# Specifying `-split-sections` in this way propagates the setting to all +# dependencies as well. The effect of this is a 50%-60% reduction in final +# binary size, with effectively no additional compilation time cost. +ghc-options: + $everything: -split-sections extra-deps: -- 'haskell-src-exts-1.23.0' - 'aeson-1.5.2.0' - 'Cabal-3.2.0.0' - 'HsYAML-aeson-0.2.0.0@rev:2' - 'HsYAML-0.2.1.0@rev:1' -- 'these-1.1.1.1' save-hackage-creds: false diff --git a/stack.yaml.lock b/stack.yaml.lock index 685b590..36c1629 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,13 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - hackage: haskell-src-exts-1.23.0@sha256:1bb9f7e97d569e56973133cb075fdcc1bfd11f90d94b035b5cf44814bb39a73d,4541 - pantry-tree: - size: 97804 - sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 - original: - hackage: haskell-src-exts-1.23.0 - completed: hackage: aeson-1.5.2.0@sha256:d00c7aa51969b2849550e4dee14c9ce188504d55ed8d7f734ce9f6976db452f6,6786 pantry-tree: @@ -39,16 +32,9 @@ packages: sha256: 77d9299977dfbc7836cbbcb51fe890bb70d485d9dd89a3bbe54822635faa8108 original: hackage: HsYAML-0.2.1.0@rev:1 -- completed: - hackage: these-1.1.1.1@sha256:3b63a3942f1da4ff97786221e3c654b969b54d570fef2cf4db97da4ea26a36cc,2609 - pantry-tree: - size: 351 - sha256: 9dbf8c39e2962926d5fb2c7bffba5e3407fed67a581ef60e2eaf3cb0c5778074 - original: - hackage: these-1.1.1.1 snapshots: - completed: - size: 491387 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/6.yaml - sha256: 8d81505a6de861e167a58534ab62330afb75bfa108735c7db1204f7ef2a39d79 - original: lts-15.6 + size: 532380 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/9.yaml + sha256: 14a7cec114424e4286adde73364438927a553ed248cc50f069a30a67e3ee1e69 + original: lts-16.9 -- cgit v1.2.3 From 481f4d453f7a8b34245995f52d27c6976f6c6b2e Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Mon, 24 Aug 2020 07:16:58 -0400 Subject: Remove split-sections stanza --- stack.yaml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index 59f2be5..3b76264 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,5 @@ resolver: lts-16.9 -# Specifying `-split-sections` in this way propagates the setting to all -# dependencies as well. The effect of this is a 50%-60% reduction in final -# binary size, with effectively no additional compilation time cost. -ghc-options: - $everything: -split-sections - extra-deps: - 'aeson-1.5.2.0' - 'Cabal-3.2.0.0' -- cgit v1.2.3 From 91a4f1647b8fa4004c135da7c49d5402939fd208 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Mon, 24 Aug 2020 19:18:14 +0800 Subject: Allow strict 0.4 Builds fine and all tests pass here. --- stylish-haskell.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8823918..2cbb77e 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -77,7 +77,7 @@ Executable stylish-haskell Build-depends: stylish-haskell, - strict >= 0.3 && < 0.4, + strict >= 0.3 && < 0.5, optparse-applicative >= 0.12 && < 0.16, -- Copied from regular dependencies... aeson >= 0.6 && < 1.6, -- cgit v1.2.3 From 14f943126394b653a6ebac215d5722eb3fe4f6c5 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Mon, 24 Aug 2020 19:18:43 +0800 Subject: Depend on semigroups only on GHC < 8.0 (#296) They are not needed on newer GHC. --- stylish-haskell.cabal | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 2cbb77e..228cab5 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -63,11 +63,14 @@ Library file-embed >= 0.0.10 && < 0.1, haskell-src-exts >= 1.18 && < 1.24, mtl >= 2.0 && < 2.3, - semigroups >= 0.18 && < 0.20, syb >= 0.3 && < 0.8, text >= 1.2 && < 1.3, HsYAML-aeson >=0.2.0 && < 0.3, HsYAML >=0.2.0 && < 0.3 + + if impl(ghc < 8.0) + Build-depends: + semigroups >= 0.18 && < 0.20 Executable stylish-haskell Ghc-options: -Wall -- cgit v1.2.3 From ce3feb1db9a0e7998a66c9dfdc7aebd9bae79477 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 24 Aug 2020 14:27:23 +0200 Subject: Switch to GitHub action --- .circleci/config.yml | 31 --------------- .circleci/release.sh | 45 --------------------- .github/workflows/ci.yml | 100 +++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 65 ++++++++++++++++++++++++++++++ 4 files changed, 165 insertions(+), 76 deletions(-) delete mode 100644 .circleci/config.yml delete mode 100755 .circleci/release.sh create mode 100644 .github/workflows/ci.yml create mode 100644 Makefile diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index c8c1def..0000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,31 +0,0 @@ -version: 2 - -workflows: - version: 2 - simple-workflow: - jobs: - - build: - filters: - tags: - only: /.*/ - -jobs: - build: - docker: - - image: 'haskell:8.8' - - steps: - - checkout - - restore_cache: - key: 'v3-stylish-haskell-{{ arch }}-{{ .Branch }}' - - run: - name: 'Build, install and test' - command: 'stack build --test --copy-bins --jobs=1' - - save_cache: - key: 'v3-stylish-haskell-{{ arch }}-{{ .Branch }}-{{ .Revision }}' - paths: - - '~/.stack-work' - - '~/.stack' - - run: - name: 'Upload release' - command: '.circleci/release.sh "$CIRCLE_TAG"' diff --git a/.circleci/release.sh b/.circleci/release.sh deleted file mode 100755 index a55247f..0000000 --- a/.circleci/release.sh +++ /dev/null @@ -1,45 +0,0 @@ -#!/bin/bash -set -o nounset -o errexit -o pipefail - -TAG="$1" -SUFFIX="linux-$(uname -m)" -USER="jaspervdj" -REPOSITORY="$(basename -- *.cabal ".cabal")" -BINARY="$REPOSITORY" - -echo "Tag: $TAG" -echo "Suffix: $SUFFIX" -echo "Repository: $REPOSITORY" - -$BINARY --version - -if [[ -z "$TAG" ]]; then - echo "Not a tagged build, skipping release..." - exit 0 -fi - -# Install ghr -GHR_VERSION="v0.13.0" -curl --silent -L -O \ - "https://github.com/tcnksm/ghr/releases/download/${GHR_VERSION}/ghr_${GHR_VERSION}_linux_386.tar.gz" -tar xf ghr_${GHR_VERSION}_linux_386.tar.gz -mv ghr_${GHR_VERSION}_linux_386/ghr . - -# Install upx -UPX_VERSION="3.94" -curl --silent -L -O \ - "https://github.com/upx/upx/releases/download/v${UPX_VERSION}/upx-${UPX_VERSION}-amd64_linux.tar.xz" -tar xf upx-${UPX_VERSION}-amd64_linux.tar.xz -mv upx-${UPX_VERSION}-amd64_linux/upx . - -# Create tarball -PACKAGE="$REPOSITORY-$TAG-$SUFFIX" -mkdir -p "$PACKAGE" -cp "$(which "$BINARY")" "$PACKAGE" -./upx -q "$PACKAGE/$BINARY" -cp CHANGELOG* LICENSE* README* "$PACKAGE" -tar -czf "$PACKAGE.tar.gz" "$PACKAGE" -rm -r "$PACKAGE" - -# Actually upload -./ghr -u "$USER" -r "$REPOSITORY" "$TAG" "$PACKAGE.tar.gz" diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..a1f5174 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,100 @@ +name: CI + +on: ['pull_request', 'push'] + +jobs: + build: + name: Build on ${{ matrix.os }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, macOS-latest] + stack: ["2.1.3"] + ghc: ["8.8.3"] + + steps: + - name: Get the version + id: get_version + run: 'echo ::set-output name=version::${GITHUB_REF#refs/tags/}' + + - uses: actions/checkout@v2 + + - uses: actions/setup-haskell@v1.1 + name: Setup Haskell Stack + with: + ghc-version: ${{ matrix.ghc }} + stack-version: ${{ matrix.stack }} + + - uses: actions/cache@v2 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-${{ matrix.ghc }}-v2 + + - name: Add ~/.local/bin to PATH + run: echo "::add-path::$HOME/.local/bin" + + - name: Build + run: make build + id: build + + - name: Test + run: make test + + - name: Build artifact + if: startsWith(github.ref, 'refs/tags') + run: make artifact + env: + PATAT_TAG: ${{ steps.get_version.outputs.version }} + + - uses: actions/upload-artifact@v2 + if: startsWith(github.ref, 'refs/tags') + with: + path: artifacts/* + name: artifacts + + release: + name: Release + needs: build + runs-on: ubuntu-latest + if: startsWith(github.ref, 'refs/tags') + + steps: + - name: Get the version + id: get_version + run: 'echo ::set-output name=version::${GITHUB_REF#refs/tags/}' + + - uses: actions/download-artifact@v2 + with: + name: artifacts + + - name: Display structure of downloaded files + run: ls -R + + - uses: actions/create-release@v1 + id: create_release + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + tag_name: ${{ steps.get_version.outputs.version }} + release_name: ${{ steps.get_version.outputs.version }} + + - name: Upload Linux Asset + uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ steps.create_release.outputs.upload_url }} + asset_path: ./stylish-haskell-${{ steps.get_version.outputs.version }}-linux-x86_64.tar.gz + asset_name: stylish-haskell-${{ steps.get_version.outputs.version }}-linux-x86_64.tar.gz + asset_content_type: application/gzip + + - name: Upload MacOS Asset + uses: actions/upload-release-asset@v1 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ steps.create_release.outputs.upload_url }} + asset_path: ./stylish-haskell-${{ steps.get_version.outputs.version }}-darwin-x86_64.zip + asset_name: stylish-haskell-${{ steps.get_version.outputs.version }}-darwin-x86_64.zip + asset_content_type: application/zip diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..058f0cd --- /dev/null +++ b/Makefile @@ -0,0 +1,65 @@ +ARCH=$(shell uname -m) +UNAME=$(shell uname | tr 'A-Z' 'a-z') + +STYLISH_BINARY=$(HOME)/.local/bin/stylish-haskell +STYLISH_TAG?=v$(shell sed -n 's/^Version: *//p' *.cabal) +STYLISH_PACKAGE=stylish-haskell-$(STYLISH_TAG)-$(UNAME)-$(ARCH) + +UPX_VERSION=3.94 +UPX_NAME=upx-$(UPX_VERSION)-amd64_$(UNAME) +UPX_BINARY=$(HOME)/.local/bin/upx + +ifeq ($(UNAME), darwin) +ARCHIVE=zip +ARCHIVE_CREATE=zip -r +ARCHIVE_EXTRACT=unzip +else +ARCHIVE=tar.gz +ARCHIVE_CREATE=tar czf +ARCHIVE_EXTRACT=tar xvzf +endif + +ifeq ($(UNAME), darwin) +COMPRESS_BIN_DEPS= +COMPRESS_BIN=ls +else +COMPRESS_BIN_DEPS=$(UPX_BINARY) +COMPRESS_BIN=upx +endif + +STACK=stack --system-ghc + +# Default target. +.PHONY: build +build: $(STYLISH_BINARY) + +# When we want to do a release. +.PHONY: artifact +artifact: $(STYLISH_PACKAGE).$(ARCHIVE) + mkdir -p artifacts + cp $(STYLISH_PACKAGE).$(ARCHIVE) artifacts/ + +$(STYLISH_PACKAGE).$(ARCHIVE): $(STYLISH_BINARY) $(COMPRESS_BIN_DEPS) + mkdir -p $(STYLISH_PACKAGE) + cp $(STYLISH_BINARY) $(STYLISH_PACKAGE)/ + $(COMPRESS_BIN) $(STYLISH_PACKAGE)/stylish-haskell + cp README.markdown $(STYLISH_PACKAGE)/ + cp CHANGELOG $(STYLISH_PACKAGE)/ + cp LICENSE $(STYLISH_PACKAGE)/ + $(ARCHIVE_CREATE) $(STYLISH_PACKAGE).$(ARCHIVE) $(STYLISH_PACKAGE) + +$(STYLISH_BINARY): + $(STACK) build --copy-bins + +# UPX is used to compress the resulting binary. We currently don't use this on +# Mac OS. +$(UPX_BINARY): + curl -Lo /tmp/$(UPX_NAME).tar.xz \ + https://github.com/upx/upx/releases/download/v$(UPX_VERSION)/$(UPX_NAME).tar.xz + cd /tmp && tar xf $(UPX_NAME).tar.xz + mv /tmp/$(UPX_NAME)/upx $(UPX_BINARY) + upx --version + +.PHONY: test +test: + stack build --test -- cgit v1.2.3 From 250e7091edd93ce5a476706ddd968ef3ec1ef336 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 2 Oct 2020 13:08:39 +0200 Subject: Use ghc-lib-parser rather than haskell-src-exts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This patch swaps out the parsing library from `haskell-src-exts` to `ghc-lib-parser`, which gives us better compatibility with GHC. Because almost every module heavily used the Haskell AST provided by `haskell-src-exts`, this was a huge effort and it would not have been possible without Felix Mulder doing an initial port, GSoC student Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and Paweł Szulc who helped me finish up things in the home stretch. I've generally tried to keep styling 100% compatible with what was there before, but some issues may have unintentionally slipped in so please report those. This introduces one new import styling contributed by Felix: when wrapping import lists over multiple lines, you can repeat the module name, e.g.: import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither) import Control.Monad.Except as X (runExceptT, withExceptT) This is activated by using `import_align: repeat`. Secondly, a new Step was added, `module_header`, which formats the export list of a module, including the trailing `where` clause. Details for this new step can be found in the `data/stylish-haskell.yaml`. Co-Authored-By: Beatrice Vergani Co-Authored-By: Paweł Szulc Co-Authored-By: Łukasz Gołębiewski Co-Authored-By: Felix Mulder --- .github/workflows/ci.yml | 4 +- data/stylish-haskell.yaml | 59 ++ lib/Language/Haskell/Stylish.hs | 17 +- lib/Language/Haskell/Stylish/Align.hs | 53 +- lib/Language/Haskell/Stylish/Block.hs | 30 +- lib/Language/Haskell/Stylish/Config.hs | 70 +- lib/Language/Haskell/Stylish/GHC.hs | 101 +++ lib/Language/Haskell/Stylish/Module.hs | 280 ++++++++ lib/Language/Haskell/Stylish/Ordering.hs | 61 ++ lib/Language/Haskell/Stylish/Parse.hs | 148 ++-- lib/Language/Haskell/Stylish/Printer.hs | 450 ++++++++++++ lib/Language/Haskell/Stylish/Step.hs | 14 +- lib/Language/Haskell/Stylish/Step/Data.hs | 586 +++++++++++++--- lib/Language/Haskell/Stylish/Step/Imports.hs | 781 +++++++++++---------- .../Haskell/Stylish/Step/LanguagePragmas.hs | 112 +-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 250 +++++++ lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 161 +++-- lib/Language/Haskell/Stylish/Step/Squash.hs | 71 +- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 39 +- lib/Language/Haskell/Stylish/Util.hs | 126 +++- src/Main.hs | 38 +- stack.yaml | 1 + stack.yaml.lock | 7 + stylish-haskell.cabal | 20 +- tests/Language/Haskell/Stylish/Config/Tests.hs | 1 + tests/Language/Haskell/Stylish/Parse/Tests.hs | 48 +- tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 694 +++++++++++++++++- .../Haskell/Stylish/Step/Imports/FelixTests.hs | 382 ++++++++++ .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 341 +++++---- .../Haskell/Stylish/Step/LanguagePragmas/Tests.hs | 293 ++++---- .../Haskell/Stylish/Step/ModuleHeader/Tests.hs | 301 ++++++++ .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 236 ++++--- tests/Language/Haskell/Stylish/Tests.hs | 8 +- tests/Language/Haskell/Stylish/Tests/Util.hs | 61 +- tests/TestSuite.hs | 4 + 35 files changed, 4591 insertions(+), 1257 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/GHC.hs create mode 100644 lib/Language/Haskell/Stylish/Module.hs create mode 100644 lib/Language/Haskell/Stylish/Ordering.hs create mode 100644 lib/Language/Haskell/Stylish/Printer.hs create mode 100644 lib/Language/Haskell/Stylish/Step/ModuleHeader.hs create mode 100644 tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a1f5174..1aa2369 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -19,7 +19,7 @@ jobs: - uses: actions/checkout@v2 - - uses: actions/setup-haskell@v1.1 + - uses: actions/setup-haskell@v1.1.2 name: Setup Haskell Stack with: ghc-version: ${{ matrix.ghc }} @@ -29,7 +29,7 @@ jobs: name: Cache ~/.stack with: path: ~/.stack - key: ${{ runner.os }}-${{ matrix.ghc }}-v2 + key: ${{ runner.os }}-${{ matrix.ghc }}-v3 - name: Add ~/.local/bin to PATH run: echo "::add-path::$HOME/.local/bin" diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index d7de260..80892dc 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -15,6 +15,19 @@ steps: # # true. # add_language_pragma: true + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # Format record definitions. This is disabled by default. # # You can control the layout of record fields. The only rules that can't be configured @@ -42,6 +55,31 @@ steps: # # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # via: "indent 2" + # + # # Wheter or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single @@ -101,6 +139,11 @@ steps: # > import qualified Data.List as List # > (concat, foldl, foldr, head, init, last, length) # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # # Default: after_alias list_align: after_alias @@ -203,6 +246,22 @@ steps: # Default: false space_surround: false + # Enabling this argument will use the new GHC lib parse to format imports. + # + # This currently assumes a few things, it will assume that you want post + # qualified imports. It is also not as feature complete as the old + # imports formatting. + # + # It does not remove redundant lines or merge lines. As such, the full + # feature scope is still pending. + # + # It _is_ however, a fine alternative if you are using features that are + # not parseable by haskell src extensions and you're comfortable with the + # presets. + # + # Default: false + ghc_lib_parser: false + # Language pragmas - language_pragmas: # We can generate different styles of language pragma lists. diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index c50db4d..a767889 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -91,14 +91,19 @@ unicodeSyntax = UnicodeSyntax.step -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines -runStep exts mfp ls step = - stepFilter step ls <$> parseModule exts mfp (unlines ls) - +runStep exts mfp ls = \case + Step _name step -> + step ls <$> parseModule exts mfp (unlines ls) -------------------------------------------------------------------------------- -runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines - -> Either String Lines -runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps +runSteps :: + Extensions + -> Maybe FilePath + -> [Step] + -> Lines + -> Either String Lines +runSteps exts mfp steps ls = + foldM (runStep exts mfp) ls steps newtype ConfigPath = ConfigPath { unConfigPath :: FilePath } diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs index 1f28d7a..c8a092f 100644 --- a/lib/Language/Haskell/Stylish/Align.hs +++ b/lib/Language/Haskell/Stylish/Align.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Align -------------------------------------------------------------------------------- import Data.List (nub) -import qualified Language.Haskell.Exts as H +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -51,49 +51,48 @@ data Alignable a = Alignable , aRightLead :: !Int } deriving (Show) - -------------------------------------------------------------------------------- -- | Create changes that perform the alignment. + align - :: Maybe Int -- ^ Max columns - -> [Alignable H.SrcSpan] -- ^ Alignables - -> [Change String] -- ^ Changes performing the alignment. + :: Maybe Int -- ^ Max columns + -> [Alignable S.RealSrcSpan] -- ^ Alignables + -> [Change String] -- ^ Changes performing the alignment align _ [] = [] align maxColumns alignment - -- Do not make any change if we would go past the maximum number of columns. - | exceedsColumns (longestLeft + longestRight) = [] - | not (fixable alignment) = [] - | otherwise = map align' alignment + -- Do not make an changes if we would go past the maximum number of columns + | exceedsColumns (longestLeft + longestRight) = [] + | not (fixable alignment) = [] + | otherwise = map align' alignment where exceedsColumns i = case maxColumns of - Nothing -> False -- No number exceeds a maximum column count of - -- Nothing, because there is no limit to exceed. - Just c -> i > c + Nothing -> False + Just c -> i > c - -- The longest thing in the left column. - longestLeft = maximum $ map (H.srcSpanEndColumn . aLeft) alignment + -- The longest thing in the left column + longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment - -- The longest thing in the right column. + -- The longest thing in the right column longestRight = maximum - [ H.srcSpanEndColumn (aRight a) - H.srcSpanStartColumn (aRight a) - + aRightLead a - | a <- alignment - ] - - align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str -> - let column = H.srcSpanEndColumn $ aLeft a - (pre, post) = splitAt column str - in [padRight longestLeft (trimRight pre) ++ trimLeft post] + [ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a) + + aRightLead a + | a <- alignment + ] + align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str -> + let column = S.srcSpanEndCol $ aLeft a + (pre, post) = splitAt column str + in [padRight longestLeft (trimRight pre) ++ trimLeft post] -------------------------------------------------------------------------------- -- | Checks that all the alignables appear on a single line, and that they do -- not overlap. -fixable :: [Alignable H.SrcSpan] -> Bool + +fixable :: [Alignable S.RealSrcSpan] -> Bool fixable [] = False fixable [_] = False fixable fields = all singleLine containers && nonOverlapping containers where containers = map aContainer fields - singleLine s = H.srcSpanStartLine s == H.srcSpanEndLine s - nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss) + singleLine s = S.srcSpanStartLine s == S.srcSpanEndLine s + nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss) diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs index 46111ee..9b07420 100644 --- a/lib/Language/Haskell/Stylish/Block.hs +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -4,20 +4,17 @@ module Language.Haskell.Stylish.Block , LineBlock , SpanBlock , blockLength - , linesFromSrcSpan - , spanFromSrcSpan , moveBlock , adjacent , merge + , mergeAdjacent , overlapping , groupAdjacent ) where -------------------------------------------------------------------------------- -import Control.Arrow (arr, (&&&), (>>>)) -import qualified Data.IntSet as IS -import qualified Language.Haskell.Exts as H +import qualified Data.IntSet as IS -------------------------------------------------------------------------------- @@ -25,7 +22,8 @@ import qualified Language.Haskell.Exts as H data Block a = Block { blockStart :: Int , blockEnd :: Int - } deriving (Eq, Ord, Show) + } + deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- @@ -40,21 +38,6 @@ type SpanBlock = Block Char blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 - --------------------------------------------------------------------------------- -linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock -linesFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartLine &&& H.srcSpanEndLine >>> - arr (uncurry Block) - - --------------------------------------------------------------------------------- -spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock -spanFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartColumn &&& H.srcSpanEndColumn >>> - arr (uncurry Block) - - -------------------------------------------------------------------------------- moveBlock :: Int -> Block a -> Block a moveBlock offset (Block start end) = Block (start + offset) (end + offset) @@ -94,3 +77,8 @@ groupAdjacent = foldr go [] go (b1, x) gs = case break (adjacent b1 . fst) gs of (_, []) -> (b1, [x]) : gs (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) + +mergeAdjacent :: [Block a] -> [Block a] +mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest +mergeAdjacent (a : rest) = a : mergeAdjacent rest +mergeAdjacent [] = [] diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 475a5e3..333736f 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,9 +1,12 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Stylish.Config ( Extensions , Config (..) + , ExitCodeBehavior (..) , defaultConfigBytes , configFilePath , loadConfig @@ -40,6 +43,7 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash @@ -60,8 +64,18 @@ data Config = Config , configLanguageExtensions :: [String] , configNewline :: IO.Newline , configCabal :: Bool + , configExitCode :: ExitCodeBehavior } +-------------------------------------------------------------------------------- +data ExitCodeBehavior + = NormalExitBehavior + | ErrorOnFormatExitBehavior + deriving (Eq) + +instance Show ExitCodeBehavior where + show NormalExitBehavior = "normal" + show ErrorOnFormatExitBehavior = "error_on_format" -------------------------------------------------------------------------------- instance FromJSON Config where @@ -126,6 +140,7 @@ parseConfig (A.Object o) = do <*> (o A..:? "language_extensions" A..!= []) <*> (o A..:? "newline" >>= parseEnum newlines IO.nativeNewline) <*> (o A..:? "cabal" A..!= True) + <*> (o A..:? "exit_code" >>= parseEnum exitCodes NormalExitBehavior) -- Then fill in the steps based on the partial config we already have stepValues <- o A..: "steps" :: A.Parser [A.Value] @@ -137,6 +152,10 @@ parseConfig (A.Object o) = do , ("lf", IO.LF) , ("crlf", IO.CRLF) ] + exitCodes = + [ ("normal", NormalExitBehavior) + , ("error_on_format", ErrorOnFormatExitBehavior) + ] parseConfig _ = mzero @@ -144,6 +163,7 @@ parseConfig _ = mzero catalog :: Map String (Config -> A.Object -> A.Parser Step) catalog = M.fromList [ ("imports", parseImports) + , ("module_header", parseModuleHeader) , ("records", parseRecords) , ("language_pragmas", parseLanguagePragmas) , ("simple_align", parseSimpleAlign) @@ -172,6 +192,11 @@ parseEnum strs _ (Just k) = case lookup k strs of Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++ intercalate ", " (map fst strs) +-------------------------------------------------------------------------------- +parseModuleHeader :: Config -> A.Object -> A.Parser Step +parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config + <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig) + <*> o A..:? "sort" A..!= (ModuleHeader.sort ModuleHeader.defaultConfig) -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step @@ -186,13 +211,20 @@ parseSimpleAlign c o = SimpleAlign.step -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step -parseRecords _ o = Data.step +parseRecords c o = Data.step <$> (Data.Config <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) <*> (o A..: "field_comment") - <*> (o A..: "deriving")) - + <*> (o A..: "deriving") + <*> (o A..:? "break_enums" A..!= False) + <*> (o A..:? "break_single_constructors" A..!= True) + <*> (o A..: "via" >>= parseIndent) + <*> (o A..:? "curried_context" A..!= False) + <*> pure configMaxColumns) + where + configMaxColumns = + maybe Data.NoMaxColumns Data.MaxColumns (configColumns c) parseIndent :: A.Value -> A.Parser Data.Indent parseIndent = A.withText "Indent" $ \t -> @@ -214,23 +246,21 @@ parseSquash _ _ = return Squash.step -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step -parseImports config o = Imports.step - <$> pure (configColumns config) - <*> (Imports.Options - <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) - <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) - <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) - <*> (o A..:? "long_list_align" - >>= parseEnum longListAligns (def Imports.longListAlign)) - -- Note that padding has to be at least 1. Default is 4. - <*> (o A..:? "empty_list_align" - >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) - <*> o A..:? "list_padding" A..!= def Imports.listPadding - <*> o A..:? "separate_lists" A..!= def Imports.separateLists - <*> o A..:? "space_surround" A..!= def Imports.spaceSurround) +parseImports config o = fmap (Imports.step columns) $ Imports.Options + <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) + <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) + <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) + <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign)) + <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) + -- Note that padding has to be at least 1. Default is 4. + <*> (o A..:? "list_padding" >>= maybe (pure $ def Imports.listPadding) parseListPadding) + <*> o A..:? "separate_lists" A..!= def Imports.separateLists + <*> o A..:? "space_surround" A..!= def Imports.spaceSurround where def f = f Imports.defaultOptions + columns = configColumns config + aligns = [ ("global", Imports.Global) , ("file", Imports.File) @@ -243,6 +273,7 @@ parseImports config o = Imports.step , ("with_module_name", Imports.WithModuleName) , ("with_alias", Imports.WithAlias) , ("after_alias", Imports.AfterAlias) + , ("repeat", Imports.Repeat) ] longListAligns = @@ -257,6 +288,11 @@ parseImports config o = Imports.step , ("right_after", Imports.RightAfter) ] + parseListPadding = \case + A.String "module_name" -> pure Imports.LPModuleName + A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) + v -> A.typeMismatch "'module_name' or >=1 number" v + -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs new file mode 100644 index 0000000..ee2d59f --- /dev/null +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} +-- | Utility functions for working with the GHC AST +module Language.Haskell.Stylish.GHC + ( dropAfterLocated + , dropBeforeLocated + , dropBeforeAndAfter + -- * Unsafe getters + , getEndLineUnsafe + , getStartLineUnsafe + -- * Standard settings + , baseDynFlags + -- * Positions + , unLocated + -- * Outputable operators + , showOutputable + , compareOutputable + ) where + +-------------------------------------------------------------------------------- +import Data.Function (on) + +-------------------------------------------------------------------------------- +import DynFlags (Settings(..), defaultDynFlags) +import qualified DynFlags as GHC +import FileSettings (FileSettings(..)) +import GHC.Fingerprint (fingerprint0) +import GHC.Platform +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion(..)) +import PlatformConstants (PlatformConstants(..)) +import SrcLoc (GenLocated(..), SrcSpan(..)) +import SrcLoc (Located, RealLocated) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import ToolSettings (ToolSettings(..)) +import qualified Outputable as GHC + +getStartLineUnsafe :: Located a -> Int +getStartLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanStartLine s + _ -> error "could not get start line of block" + +getEndLineUnsafe :: Located a -> Int +getEndLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanEndLine s + _ -> error "could not get end line of block" + +dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropAfterLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs + _ -> xs + +dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropBeforeLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs + _ -> xs + +dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b] +dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc) + +baseDynFlags :: GHC.DynFlags +baseDynFlags = defaultDynFlags fakeSettings llvmConfig + where + fakeSettings = GHC.Settings + { sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion + , sFileSettings = FileSettings {} + , sToolSettings = ToolSettings + { toolSettings_opt_P_fingerprint = fingerprint0, + toolSettings_pgm_F = "" + } + , sPlatformConstants = PlatformConstants + { pc_DYNAMIC_BY_DEFAULT = False + , pc_WORD_SIZE = 8 + } + , sTargetPlatform = Platform + { platformMini = PlatformMini + { platformMini_arch = ArchUnknown + , platformMini_os = OSUnknown + } + , platformWordSize = PW8 + , platformUnregisterised = True + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols = False + , platformIsCrossCompiling = False + } + , sPlatformMisc = PlatformMisc {} + , sRawSettings = [] + } + + llvmConfig = GHC.LlvmConfig [] [] + +unLocated :: Located a -> a +unLocated (L _ a) = a + +showOutputable :: GHC.Outputable a => a -> String +showOutputable = GHC.showPpr baseDynFlags + +compareOutputable :: GHC.Outputable a => a -> a -> Ordering +compareOutputable = compare `on` showOutputable diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs new file mode 100644 index 0000000..3647f3c --- /dev/null +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Stylish.Module + ( -- * Data types + Module (..) + , ModuleHeader + , Import + , Decls + , Comments + , Lines + , makeModule + + -- * Getters + , moduleHeader + , moduleImports + , moduleImportGroups + , moduleDecls + , moduleComments + , moduleLanguagePragmas + , queryModule + + -- * Imports + , canMergeImport + , mergeModuleImport + + -- * Annotations + , lookupAnnotation + + -- * Internal API getters + , rawComments + , rawImport + , rawModuleAnnotations + , rawModuleDecls + , rawModuleExports + , rawModuleHaddocks + , rawModuleName + ) where + +-------------------------------------------------------------------------------- +import Data.Function ((&), on) +import Data.Functor ((<&>)) +import Data.Generics (Typeable, everything, mkQ) +import Data.Maybe (mapMaybe) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List (nubBy, sort) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Data (Data) + +-------------------------------------------------------------------------------- +import qualified ApiAnnotation as GHC +import qualified Lexer as GHC +import GHC.Hs (ImportDecl(..), ImportDeclQualifiedStyle(..)) +import qualified GHC.Hs as GHC +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Decls (LHsDecl) +import Outputable (Outputable) +import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (RealSrcSpan(..), SrcSpan(..)) +import SrcLoc (Located) +import qualified SrcLoc as GHC +import qualified Module as GHC + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC + +-------------------------------------------------------------------------------- +type Lines = [String] + + +-------------------------------------------------------------------------------- +-- | Concrete module type +data Module = Module + { parsedComments :: [GHC.RealLocated GHC.AnnotationComment] + , parsedAnnotations :: [(GHC.ApiAnnKey, [GHC.SrcSpan])] + , parsedAnnotSrcs :: Map RealSrcSpan [GHC.AnnKeywordId] + , parsedModule :: GHC.Located (GHC.HsModule GhcPs) + } deriving (Data) + +-- | Declarations in module +newtype Decls = Decls [LHsDecl GhcPs] + +-- | Import declaration in module +newtype Import = Import { unImport :: ImportDecl GhcPs } + deriving newtype (Outputable) + +-- | Returns true if the two import declarations can be merged +canMergeImport :: Import -> Import -> Bool +canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1) + [ (==) `on` unLocated . ideclName + , (==) `on` ideclPkgQual + , (==) `on` ideclSource + , hasMergableQualified `on` ideclQualified + , (==) `on` ideclImplicit + , (==) `on` fmap unLocated . ideclAs + , (==) `on` fmap fst . ideclHiding -- same 'hiding' flags + ] + where + hasMergableQualified QualifiedPre QualifiedPost = True + hasMergableQualified QualifiedPost QualifiedPre = True + hasMergableQualified q0 q1 = q0 == q1 + +instance Eq Import where + i0 == i1 = canMergeImport i0 i1 && hasSameImports (unImport i0) (unImport i1) + where + hasSameImports = (==) `on` fmap snd . ideclHiding + +instance Ord Import where + compare (Import i0) (Import i1) = + ideclName i0 `compareOutputable` ideclName i1 <> + fmap showOutputable (ideclPkgQual i0) `compare` + fmap showOutputable (ideclPkgQual i1) <> + compareOutputable i0 i1 + +-- | Comments associated with module +newtype Comments = Comments [GHC.RealLocated GHC.AnnotationComment] + +-- | A module header is its name, exports and haddock docstring +data ModuleHeader = ModuleHeader + { name :: Maybe (GHC.Located GHC.ModuleName) + , exports :: Maybe (GHC.Located [GHC.LIE GhcPs]) + , haddocks :: Maybe GHC.LHsDocString + } + +-- | Create a module from GHC internal representations +makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module +makeModule pstate = Module comments annotations annotationMap + where + comments + = sort + . filterRealLocated + $ GHC.comment_q pstate ++ (GHC.annotations_comments pstate >>= snd) + + filterRealLocated = mapMaybe \case + GHC.L (GHC.RealSrcSpan s) e -> Just (GHC.L s e) + GHC.L (GHC.UnhelpfulSpan _) _ -> Nothing + + annotations + = GHC.annotations pstate + + annotationMap + = GHC.annotations pstate + & mapMaybe x + & Map.fromListWith (++) + + x = \case + ((RealSrcSpan rspan, annot), _) -> Just (rspan, [annot]) + _ -> Nothing + +-- | Get all declarations in module +moduleDecls :: Module -> Decls +moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule + +-- | Get comments in module +moduleComments :: Module -> Comments +moduleComments = Comments . parsedComments + +-- | Get module language pragmas +moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty Text)] +moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments + where + toLanguagePragma :: RealLocated GHC.AnnotationComment -> Maybe (RealSrcSpan, NonEmpty Text) + toLanguagePragma = \case + L pos (GHC.AnnBlockComment s) -> + Just (T.pack s) + >>= T.stripPrefix "{-#" + >>= T.stripSuffix "#-}" + <&> T.strip + <&> T.splitAt 8 -- length "LANGUAGE" + <&> fmap (T.splitOn ",") + <&> fmap (fmap T.strip) + <&> fmap (filter (not . T.null)) + >>= (\(T.toUpper . T.strip -> lang, xs) -> (lang,) <$> nonEmpty xs) + >>= (\(lang, nel) -> if lang == "LANGUAGE" then Just (pos, nel) else Nothing) + _ -> Nothing + +-- | Get module imports +moduleImports :: Module -> [Located Import] +moduleImports m + = parsedModule m + & unLocated + & GHC.hsmodImports + & fmap \(L pos i) -> L pos (Import i) + +-- | Get groups of imports from module +moduleImportGroups :: Module -> [NonEmpty (Located Import)] +moduleImportGroups = go [] Nothing . moduleImports + where + -- Run through all imports (assume they are sorted already in order of + -- appearance in the file) and group the ones that are on consecutive + -- lines. + go :: [Located Import] -> Maybe Int -> [Located Import] + -> [NonEmpty (Located Import)] + go acc _ [] = ne acc + go acc mbCurrentLine (imp : impRest) = + let l2 = getStartLineUnsafe imp in + case mbCurrentLine of + Just l1 | l1 + 1 < l2 -> ne acc ++ go [imp] (Just l2) impRest + _ -> go (acc ++ [imp]) (Just l2) impRest + + ne [] = [] + ne (x : xs) = [x :| xs] + +-- | Merge two import declarations, keeping positions from the first +-- +-- As alluded, this highlights an issue with merging imports. The GHC +-- annotation comments aren't attached to any particular AST node. This +-- means that right now, we're manually reconstructing the attachment. By +-- merging two import declarations, we lose that mapping. +-- +-- It's not really a big deal if we consider that people don't usually +-- comment imports themselves. It _is_ however, systemic and it'd be better +-- if we processed comments beforehand and attached them to all AST nodes in +-- our own representation. +mergeModuleImport :: Located Import -> Located Import -> Located Import +mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) = + L p0 $ Import i0 { ideclHiding = newImportNames } + where + newImportNames = + case (ideclHiding i0, ideclHiding i1) of + (Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1)) + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> Just x + (Nothing, Just x) -> Just x + merge xs ys + = nubBy ((==) `on` showOutputable) (xs ++ ys) + +-- | Get module header +moduleHeader :: Module -> ModuleHeader +moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader + { name = GHC.hsmodName m + , exports = GHC.hsmodExports m + , haddocks = GHC.hsmodHaddockModHeader m + } + +-- | Query for annotations associated with a 'SrcSpan' +lookupAnnotation :: SrcSpan -> Module -> [GHC.AnnKeywordId] +lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m) +lookupAnnotation (UnhelpfulSpan _) _ = [] + +-- | Query the module AST using @f@ +queryModule :: Typeable a => (a -> [b]) -> Module -> [b] +queryModule f = everything (++) (mkQ [] f) . parsedModule + +-------------------------------------------------------------------------------- +-- | Getter for internal components in imports newtype +rawImport :: Import -> ImportDecl GhcPs +rawImport (Import i) = i + +-- | Getter for internal module name representation +rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName) +rawModuleName = name + +-- | Getter for internal module exports representation +rawModuleExports :: ModuleHeader -> Maybe (GHC.Located [GHC.LIE GhcPs]) +rawModuleExports = exports + +-- | Getter for internal module haddocks representation +rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString +rawModuleHaddocks = haddocks + +-- | Getter for internal module decls representation +rawModuleDecls :: Decls -> [LHsDecl GhcPs] +rawModuleDecls (Decls xs) = xs + +-- | Getter for internal module comments representation +rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] +rawComments (Comments xs) = xs + +-- | Getter for internal module annotation representation +rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])] +rawModuleAnnotations = parsedAnnotations diff --git a/lib/Language/Haskell/Stylish/Ordering.hs b/lib/Language/Haskell/Stylish/Ordering.hs new file mode 100644 index 0000000..1a05eb4 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Ordering.hs @@ -0,0 +1,61 @@ +-------------------------------------------------------------------------------- +-- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader', +-- and maybe more in the future. This module provides consistent sorting +-- utilities. +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Ordering + ( compareLIE + , compareWrappedName + , unwrapName + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isUpper) +import Data.Ord (comparing) +import GHC.Hs +import RdrName (RdrName) +import SrcLoc (unLoc) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC (showOutputable) +import Outputable (Outputable) + + +-------------------------------------------------------------------------------- +-- | NOTE: Can we get rid off this by adding a properly sorting newtype around +-- 'RdrName'? +compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering +compareLIE = comparing $ ieKey . unLoc + where + -- | The implementation is a bit hacky to get proper sorting for input specs: + -- constructors first, followed by functions, and then operators. + ieKey :: IE GhcPs -> (Int, String) + ieKey = \case + IEVar _ n -> nameKey n + IEThingAbs _ n -> nameKey n + IEThingAll _ n -> nameKey n + IEThingWith _ n _ _ _ -> nameKey n + IEModuleContents _ n -> nameKey n + _ -> (2, "") + + +-------------------------------------------------------------------------------- +compareWrappedName :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering +compareWrappedName = comparing nameKey + + +-------------------------------------------------------------------------------- +unwrapName :: IEWrappedName n -> n +unwrapName (IEName n) = unLoc n +unwrapName (IEPattern n) = unLoc n +unwrapName (IEType n) = unLoc n + + +-------------------------------------------------------------------------------- +nameKey :: Outputable name => name -> (Int, String) +nameKey n = case showOutputable n of + o@('(' : _) -> (2, o) + o@(o0 : _) | isUpper o0 -> (0, o) + o -> (1, o) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 01def63..b416a32 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -1,35 +1,39 @@ +{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse - ( parseModule - ) where + ( parseModule + ) where -------------------------------------------------------------------------------- -import Data.List (isPrefixOf, nub) +import Data.Function ((&)) import Data.Maybe (fromMaybe, listToMaybe) -import qualified Language.Haskell.Exts as H - +import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config -import Language.Haskell.Stylish.Step - +import Bag (bagToList) +import qualified DynFlags as GHC +import qualified ErrUtils as GHC +import FastString (mkFastString) +import qualified GHC.Hs as GHC +import qualified GHC.LanguageExtensions as GHC +import qualified HeaderInfo as GHC +import qualified HscTypes as GHC +import Lexer (ParseResult (..)) +import Lexer (mkPState, unP) +import qualified Lexer as GHC +import qualified Panic as GHC +import qualified Parser as GHC +import SrcLoc (mkRealSrcLoc) +import qualified SrcLoc as GHC +import StringBuffer (stringToStringBuffer) +import qualified StringBuffer as GHC -------------------------------------------------------------------------------- --- | Syntax-related language extensions are always enabled for parsing. Since we --- can't authoritatively know which extensions are enabled at compile-time, we --- should try not to throw errors when parsing any GHC-accepted code. -defaultExtensions :: [H.Extension] -defaultExtensions = map H.EnableExtension - [ H.GADTs - , H.HereDocuments - , H.KindSignatures - , H.NewQualifiedOperators - , H.PatternGuards - , H.StandaloneDeriving - , H.UnicodeSyntax - ] +import Language.Haskell.Stylish.GHC (baseDynFlags) +import Language.Haskell.Stylish.Module +type Extensions = [String] -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros @@ -42,15 +46,6 @@ unCpp = unlines . go False . lines nextMultiline = isCpp && not (null x) && last x == '\\' in (if isCpp then "" else x) : go nextMultiline xs - --------------------------------------------------------------------------------- --- | Remove shebang lines -unShebang :: String -> String -unShebang str = - let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in - unlines $ map (const "") shebangs ++ other - - -------------------------------------------------------------------------------- -- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it -- because haskell-src-exts can't handle it. @@ -60,32 +55,69 @@ dropBom str = str -------------------------------------------------------------------------------- --- | Abstraction over HSE's parsing +-- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule extraExts mfp string = do - -- Determine the extensions: those specified in the file and the extra ones - let noPrefixes = unShebang . dropBom $ string - extraExts' = map H.classifyExtension extraExts - (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes - exts = nub $ fileExts ++ extraExts' ++ defaultExtensions - - -- Parsing options... - fp = fromMaybe "" mfp - mode = H.defaultParseMode - { H.extensions = exts - , H.fixities = Nothing - , H.baseLanguage = case lang of - Nothing -> H.baseLanguage H.defaultParseMode - Just l -> l - } - - -- Preprocessing - processed = if H.EnableExtension H.CPP `elem` exts - then unCpp noPrefixes - else noPrefixes - - case H.parseModuleWithComments mode processed of - H.ParseOk md -> return md - err -> Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ - fp ++ ": " ++ show err +parseModule exts fp string = + parsePragmasIntoDynFlags baseDynFlags userExtensions filePath string >>= \dynFlags -> + dropBom string + & removeCpp dynFlags + & runParser dynFlags + & toModule dynFlags + where + toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module + toModule dynFlags res = case res of + POk ps m -> + Right (makeModule ps m) + PFailed failureState -> + let + withFileName x = maybe "" (<> ": ") fp <> x + in + Left . withFileName . unlines . getParserStateErrors dynFlags $ failureState + + removeCpp dynFlags s = + if GHC.xopt GHC.Cpp dynFlags then unCpp s + else s + + userExtensions = + fmap toLocatedExtensionFlag ("Haskell2010" : exts) -- FIXME: do we need `Haskell2010` here? + + toLocatedExtensionFlag flag + = "-X" <> flag + & GHC.L GHC.noSrcSpan + + getParserStateErrors dynFlags state + = GHC.getErrorMessages state dynFlags + & bagToList + & fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg) + + filePath = + fromMaybe "" fp + + runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) + runParser flags str = + let + filename = mkFastString filePath + parseState = mkPState flags (stringToStringBuffer str) (mkRealSrcLoc filename 1 1) + in + unP GHC.parseModule parseState + +-- | Parse 'DynFlags' from the extra options +-- +-- /Note:/ this function would be IO, but we're not using any of the internal +-- features that constitute side effectful computation. So I think it's fine +-- if we run this to avoid changing the interface too much. +parsePragmasIntoDynFlags :: + GHC.DynFlags + -> [GHC.Located String] + -> FilePath + -> String + -> Either String GHC.DynFlags +{-# NOINLINE parsePragmasIntoDynFlags #-} +parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO $ catchErrors $ do + let opts = GHC.getOptions originalFlags (GHC.stringToStringBuffer str) filepath + (parsedFlags, _invalidFlags, _warnings) <- GHC.parseDynamicFilePragma originalFlags (opts <> extraOpts) + -- FIXME: have a look at 'leftovers' since it should be empty + return $ Right $ parsedFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + where + catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act) + reportErr e = return $ Left (show e) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs new file mode 100644 index 0000000..886f912 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Printer + ( Printer(..) + , PrinterConfig(..) + , PrinterState(..) + + -- * Alias + , P + + -- * Functions to use the printer + , runPrinter + , runPrinter_ + + -- ** Combinators + , comma + , dot + , getAnnot + , getCurrentLine + , getCurrentLineLength + , getDocstrPrev + , newline + , parenthesize + , peekNextCommentPos + , prefix + , putComment + , putEolComment + , putOutputable + , putAllSpanComments + , putCond + , putType + , putRdrName + , putText + , removeCommentTo + , removeCommentToEnd + , removeLineComment + , sep + , groupAttachedComments + , space + , spaces + , suffix + + -- ** Advanced combinators + , withColumns + , modifyCurrentLine + , wrapping + ) where + +-------------------------------------------------------------------------------- +import Prelude hiding (lines) + +-------------------------------------------------------------------------------- +import ApiAnnotation (AnnKeywordId(..), AnnotationComment(..)) +import GHC.Hs.Extension (GhcPs, NoExtField(..)) +import GHC.Hs.Types (HsType(..)) +import Module (ModuleName, moduleNameString) +import RdrName (RdrName(..)) +import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (Located, SrcSpan(..)) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import Outputable (Outputable) + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, replicateM_) +import Control.Monad.Reader (MonadReader, ReaderT(..), asks, local) +import Control.Monad.State (MonadState, State) +import Control.Monad.State (runState) +import Control.Monad.State (get, gets, modify, put) +import Data.Foldable (find) +import Data.Functor ((<&>)) +import Data.List (delete, isPrefixOf) +import Data.List.NonEmpty (NonEmpty(..)) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module (Module, Lines, lookupAnnotation) +import Language.Haskell.Stylish.GHC (showOutputable, unLocated) + +-- | Shorthand for 'Printer' monad +type P = Printer + +-- | Printer that keeps state of file +newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) + deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState) + +-- | Configuration for printer, currently empty +data PrinterConfig = PrinterConfig + { columns :: !(Maybe Int) + } + +-- | State of printer +data PrinterState = PrinterState + { lines :: !Lines + , linePos :: !Int + , currentLine :: !String + , pendingComments :: ![RealLocated AnnotationComment] + , parsedModule :: !Module + } + +-- | Run printer to get printed lines out of module as well as return value of monad +runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> (a, Lines) +runPrinter cfg comments m (Printer printer) = + let + (a, PrinterState parsedLines _ startedLine _ _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments m + in + (a, parsedLines <> if startedLine == [] then [] else [startedLine]) + +-- | Run printer to get printed lines only +runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines +runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer) + +-- | Print text +putText :: String -> P () +putText txt = do + l <- gets currentLine + modify \s -> s { currentLine = l <> txt } + +-- | Check condition post action, and use fallback if false +putCond :: (PrinterState -> Bool) -> P b -> P b -> P b +putCond p action fallback = do + prevState <- get + res <- action + currState <- get + if p currState then pure res + else put prevState >> fallback + +-- | Print an 'Outputable' +putOutputable :: Outputable a => a -> P () +putOutputable = putText . showOutputable + +-- | Put all comments that has positions within 'SrcSpan' and separate by +-- passed @P ()@ +putAllSpanComments :: P () -> SrcSpan -> P () +putAllSpanComments suff = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> do + cmts <- removeComments \(L rloc _) -> + srcSpanStartLine rloc >= srcSpanStartLine rspan && + srcSpanEndLine rloc <= srcSpanEndLine rspan + + forM_ cmts (\c -> putComment c >> suff) + +-- | Print any comment +putComment :: AnnotationComment -> P () +putComment = \case + AnnLineComment s -> putText s + AnnDocCommentNext s -> putText s + AnnDocCommentPrev s -> putText s + AnnDocCommentNamed s -> putText s + AnnDocSection _ s -> putText s + AnnDocOptions s -> putText s + AnnBlockComment s -> putText s + +-- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line +putEolComment :: SrcSpan -> P () +putEolComment = \case + RealSrcSpan rspan -> do + cmt <- removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan == srcSpanStartLine rloc + , not ("-- ^" `isPrefixOf` s) + , not ("-- |" `isPrefixOf` s) + ] + _ -> False + forM_ cmt (\c -> space >> putComment c) + UnhelpfulSpan _ -> pure () + +-- | Print a 'RdrName' +putRdrName :: Located RdrName -> P () +putRdrName (L pos n) = case n of + Unqual name -> do + annots <- getAnnot pos + if AnnOpenP `elem` annots then do + putText "(" + putText (showOutputable name) + putText ")" + else if AnnBackquote `elem` annots then do + putText "`" + putText (showOutputable name) + putText "`" + else if AnnSimpleQuote `elem` annots then do + putText "'" + putText (showOutputable name) + else + putText (showOutputable name) + Qual modulePrefix name -> + putModuleName modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> + putText (showOutputable name) + Exact name -> + putText (showOutputable name) + +-- | Print module name +putModuleName :: ModuleName -> P () +putModuleName = putText . moduleNameString + +-- | Print type +putType :: Located (HsType GhcPs) -> P () +putType ltp = case unLocated ltp of + HsFunTy NoExtField argTp funTp -> do + putOutputable argTp + space + putText "->" + space + putType funTp + HsAppTy NoExtField t1 t2 -> + putType t1 >> space >> putType t2 + HsExplicitListTy NoExtField _ xs -> do + putText "'[" + sep + (comma >> space) + (fmap putType xs) + putText "]" + HsExplicitTupleTy NoExtField xs -> do + putText "'(" + sep + (comma >> space) + (fmap putType xs) + putText ")" + HsOpTy NoExtField lhs op rhs -> do + putType lhs + space + putRdrName op + space + putType rhs + HsTyVar NoExtField _ rdrName -> + putRdrName rdrName + HsTyLit _ tp -> + putOutputable tp + HsParTy _ tp -> do + putText "(" + putType tp + putText ")" + HsTupleTy NoExtField _ xs -> do + putText "(" + sep + (comma >> space) + (fmap putType xs) + putText ")" + HsForAllTy NoExtField _ _ _ -> + putOutputable ltp + HsQualTy NoExtField _ _ -> + putOutputable ltp + HsAppKindTy _ _ _ -> + putOutputable ltp + HsListTy _ _ -> + putOutputable ltp + HsSumTy _ _ -> + putOutputable ltp + HsIParamTy _ _ _ -> + putOutputable ltp + HsKindSig _ _ _ -> + putOutputable ltp + HsStarTy _ _ -> + putOutputable ltp + HsSpliceTy _ _ -> + putOutputable ltp + HsDocTy _ _ _ -> + putOutputable ltp + HsBangTy _ _ _ -> + putOutputable ltp + HsRecTy _ _ -> + putOutputable ltp + HsWildCardTy _ -> + putOutputable ltp + XHsType _ -> + putOutputable ltp + +-- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment +getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment) +getDocstrPrev = \case + UnhelpfulSpan _ -> pure Nothing + RealSrcSpan rspan -> do + removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan == srcSpanStartLine rloc + , "-- ^" `isPrefixOf` s + ] + _ -> False + +-- | Print a newline +newline :: P () +newline = do + l <- gets currentLine + modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] } + +-- | Print a space +space :: P () +space = putText " " + +-- | Print a number of spaces +spaces :: Int -> P () +spaces i = replicateM_ i space + +-- | Print a dot +dot :: P () +dot = putText "." + +-- | Print a comma +comma :: P () +comma = putText "," + +-- | Add parens around a printed action +parenthesize :: P a -> P a +parenthesize action = putText "(" *> action <* putText ")" + +-- | Add separator between each element of the given printers +sep :: P a -> [P a] -> P () +sep _ [] = pure () +sep s (first : rest) = first >> forM_ rest ((>>) s) + +-- | Prefix a printer with another one +prefix :: P a -> P b -> P b +prefix pa pb = pa >> pb + +-- | Suffix a printer with another one +suffix :: P a -> P b -> P a +suffix pa pb = pb >> pa + +-- | Gets comment on supplied 'line' and removes it from the state +removeLineComment :: Int -> P (Maybe AnnotationComment) +removeLineComment line = + removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) + +-- | Removes comments from the state up to start line of 'SrcSpan' and returns +-- the ones that were removed +removeCommentTo :: SrcSpan -> P [AnnotationComment] +removeCommentTo = \case + UnhelpfulSpan _ -> pure [] + RealSrcSpan rspan -> removeCommentTo' (srcSpanStartLine rspan) + +-- | Removes comments from the state up to end line of 'SrcSpan' and returns +-- the ones that were removed +removeCommentToEnd :: SrcSpan -> P [AnnotationComment] +removeCommentToEnd = \case + UnhelpfulSpan _ -> pure [] + RealSrcSpan rspan -> removeCommentTo' (srcSpanEndLine rspan) + +-- | Removes comments to the line number given and returns the ones removed +removeCommentTo' :: Int -> P [AnnotationComment] +removeCommentTo' line = + removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case + Nothing -> pure [] + Just c -> do + rest <- removeCommentTo' line + pure (c : rest) + +-- | Removes comments from the state while given predicate 'p' is true +removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment] +removeComments p = + removeComment p >>= \case + Just c -> do + rest <- removeComments p + pure (c : rest) + Nothing -> pure [] + +-- | Remove a comment from the state given predicate 'p' +removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment) +removeComment p = do + comments <- gets pendingComments + + let + foundComment = + find p comments + + newPendingComments = + maybe comments (`delete` comments) foundComment + + modify \s -> s { pendingComments = newPendingComments } + pure $ fmap (\(L _ c) -> c) foundComment + +-- | Get all annotations for 'SrcSpan' +getAnnot :: SrcSpan -> P [AnnKeywordId] +getAnnot spn = gets (lookupAnnotation spn . parsedModule) + +-- | Get current line +getCurrentLine :: P String +getCurrentLine = gets currentLine + +-- | Get current line length +getCurrentLineLength :: P Int +getCurrentLineLength = fmap length getCurrentLine + +-- | Peek at the next comment in the state +peekNextCommentPos :: P (Maybe SrcSpan) +peekNextCommentPos = do + gets pendingComments <&> \case + (L next _ : _) -> Just (RealSrcSpan next) + [] -> Nothing + +-- | Get attached comments belonging to '[Located a]' given +groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] +groupAttachedComments = go + where + go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] + go (L rspan x : xs) = do + comments <- removeCommentTo rspan + nextGroupStartM <- peekNextCommentPos + + let + sameGroupOf = maybe xs \nextGroupStart -> + takeWhile (\(L p _)-> p < nextGroupStart) xs + + restOf = maybe [] \nextGroupStart -> + dropWhile (\(L p _) -> p <= nextGroupStart) xs + + restGroups <- go (restOf nextGroupStartM) + pure $ (comments, L rspan x :| sameGroupOf nextGroupStartM) : restGroups + + go _ = pure [] + +modifyCurrentLine :: (String -> String) -> P () +modifyCurrentLine f = do + s0 <- get + put s0 {currentLine = f $ currentLine s0} + +wrapping + :: P a -- ^ First printer to run + -> P a -- ^ Printer to run if first printer violates max columns + -> P a -- ^ Result of either the first or the second printer +wrapping p1 p2 = do + maxCols <- asks columns + case maxCols of + -- No wrapping + Nothing -> p1 + Just c -> do + s0 <- get + x <- p1 + s1 <- get + if length (currentLine s1) <= c + -- No need to wrap + then pure x + else do + put s0 + y <- p2 + s2 <- get + if length (currentLine s1) == length (currentLine s2) + -- Wrapping didn't help! + then put s1 >> pure x + -- Wrapped + else pure y + +withColumns :: Maybe Int -> P a -> P a +withColumns c = local $ \pc -> pc {columns = c} diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs index e5f3424..c2cfc70 100644 --- a/lib/Language/Haskell/Stylish/Step.hs +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -1,24 +1,13 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step ( Lines - , Module , Step (..) , makeStep ) where -------------------------------------------------------------------------------- -import qualified Language.Haskell.Exts as H - - --------------------------------------------------------------------------------- -type Lines = [String] - - --------------------------------------------------------------------------------- --- | Concrete module type -type Module = (H.Module H.SrcSpanInfo, [H.Comment]) - +import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- data Step = Step @@ -26,7 +15,6 @@ data Step = Step , stepFilter :: Lines -> Module -> Lines } - -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step makeStep = Step diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 1f7732b..bf39c7c 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,126 +1,518 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +module Language.Haskell.Stylish.Step.Data + ( Config(..) + , Indent(..) + , MaxColumns(..) + , step + ) where -module Language.Haskell.Stylish.Step.Data where +-------------------------------------------------------------------------------- +import Prelude hiding (init) -import Data.List (find, intercalate) -import Data.Maybe (fromMaybe, maybeToList) -import qualified Language.Haskell.Exts as H -import Language.Haskell.Exts.Comments +-------------------------------------------------------------------------------- +import Control.Monad (forM_, unless, when) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.List (sortBy) +import Data.Maybe (listToMaybe) + +-------------------------------------------------------------------------------- +import ApiAnnotation (AnnotationComment) +import BasicTypes (LexicalFixity(..)) +import GHC.Hs.Decls (HsDecl(..), HsDataDefn(..)) +import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) +import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) +import GHC.Hs.Decls (ConDecl(..)) +import GHC.Hs.Extension (GhcPs, NoExtField(..), noExtCon) +import GHC.Hs.Types (ConDeclField(..), HsContext) +import GHC.Hs.Types (HsType(..), ForallVisFlag(..)) +import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) +import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) +import RdrName (RdrName) +import SrcLoc (Located, RealLocated) +import SrcLoc (GenLocated(..)) + +-------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util -import Prelude hiding (init) data Indent = SameLine | Indent !Int - deriving (Show) + deriving (Show, Eq) + +data MaxColumns + = MaxColumns !Int + | NoMaxColumns + deriving (Show, Eq) data Config = Config - { cEquals :: !Indent + { cEquals :: !Indent -- ^ Indent between type constructor and @=@ sign (measured from column 0) - , cFirstField :: !Indent + , cFirstField :: !Indent -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name) - , cFieldComment :: !Int + , cFieldComment :: !Int -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@) - , cDeriving :: !Int + , cDeriving :: !Int -- ^ Indent before @deriving@ lines (measured from column 0) + , cBreakEnums :: !Bool + -- ^ Break enums by newlines and follow the above rules + , cBreakSingleConstructors :: !Bool + -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@ + , cVia :: !Indent + -- ^ Indentation between @via@ clause and start of deriving column start + , cCurriedContext :: !Bool + -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + , cMaxColumns :: !MaxColumns } deriving (Show) -datas :: H.Module l -> [H.Decl l] -datas (H.Module _ _ _ _ decls) = decls -datas _ = [] +step :: Config -> Step +step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls + where + changes :: Module -> [ChangeLine] + changes m = fmap (formatDataDecl cfg m) (dataDecls m) -type ChangeLine = Change String + dataDecls :: Module -> [Located DataDecl] + dataDecls = queryModule \case + L pos (TyClD _ (DataDecl _ name tvars fixity defn)) -> pure . L pos $ MkDataDecl + { dataDeclName = name + , dataTypeVars = tvars + , dataDefn = defn + , dataFixity = fixity + } + _ -> [] -step :: Config -> Step -step cfg = makeStep "Data" (step' cfg) +type ChangeLine = Change String -step' :: Config -> Lines -> Module -> Lines -step' cfg ls (module', allComments) = applyChanges changes ls +formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine +formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = + change originalDeclBlock (const printedDecl) where - datas' = datas $ fmap linesFromSrcSpan module' - changes = datas' >>= maybeToList . changeDecl allComments cfg + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropBeforeAndAfter ldecl -findCommentOnLine :: LineBlock -> [Comment] -> Maybe Comment -findCommentOnLine lb = find commentOnLine - where - commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) = - blockStart lb == start && blockEnd lb == end + defn = dataDefn decl + + originalDeclBlock = + Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) + + printerConfig = PrinterConfig + { columns = case cMaxColumns of + NoMaxColumns -> Nothing + MaxColumns n -> Just n + } + + printedDecl = runPrinter_ printerConfig relevantComments m do + putText (newOrData decl) + space + putName decl + + when (isGADT decl) (space >> putText "where") + + when (hasConstructors decl) do + breakLineBeforeEq <- case (cEquals, cFirstField) of + (_, Indent x) | isEnum decl && cBreakEnums -> do + putEolComment declPos + newline >> spaces x + pure True + (_, _) | not (isNewtype decl) && singleConstructor decl && not cBreakSingleConstructors -> + False <$ space + (Indent x, _) + | isEnum decl && not cBreakEnums -> False <$ space + | otherwise -> do + putEolComment declPos + newline >> spaces x + pure True + (SameLine, _) -> False <$ space + + lineLengthAfterEq <- fmap (+2) getCurrentLineLength + + if isEnum decl && not cBreakEnums then + putText "=" >> space >> putUnbrokenEnum cfg decl + else if isNewtype decl then + putText "=" >> space >> forM_ (dd_cons defn) (putNewtypeConstructor cfg) + else + case dd_cons defn of + [] -> pure () + lcon@(L pos _) : consRest -> do + when breakLineBeforeEq do + removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq + + unless + (isGADT decl) + (putText "=" >> space) + + putConstructor cfg lineLengthAfterEq lcon + forM_ consRest \con@(L conPos _) -> do + unless (cFirstField == SameLine) do + removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c + consIndent lineLengthAfterEq + + unless + (isGADT decl) + (putText "|" >> space) + + putConstructor cfg lineLengthAfterEq con + putEolComment conPos + + when (hasDeriving decl) do + if isEnum decl && not cBreakEnums then + space + else do + removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= + mapM_ \c -> newline >> spaces cDeriving >> putComment c + newline + spaces cDeriving + + sep (newline >> spaces cDeriving) $ defn & dd_derivs & \(L pos ds) -> ds <&> \d -> do + putAllSpanComments (newline >> spaces cDeriving) pos + putDeriving cfg d + + consIndent eqIndent = newline >> case (cEquals, cFirstField) of + (SameLine, SameLine) -> spaces (eqIndent - 2) + (SameLine, Indent y) -> spaces (eqIndent + y - 4) + (Indent x, Indent _) -> spaces x + (Indent x, SameLine) -> spaces x + +data DataDecl = MkDataDecl + { dataDeclName :: Located RdrName + , dataTypeVars :: LHsQTyVars GhcPs + , dataDefn :: HsDataDefn GhcPs + , dataFixity :: LexicalFixity + } + +putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P () +putDeriving Config{..} (L pos clause) = do + putText "deriving" + + forM_ (deriv_clause_strategy clause) \case + L _ StockStrategy -> space >> putText "stock" + L _ AnyclassStrategy -> space >> putText "anyclass" + L _ NewtypeStrategy -> space >> putText "newtype" + L _ (ViaStrategy _) -> pure () + + putCond + withinColumns + oneLinePrint + multilinePrint + + forM_ (deriv_clause_strategy clause) \case + L _ (ViaStrategy tp) -> do + case cVia of + SameLine -> space + Indent x -> newline >> spaces (x + cDeriving) + + putText "via" + space + putType (getType tp) + _ -> pure () + + putEolComment pos -findCommentBelowLine :: LineBlock -> [Comment] -> Maybe Comment -findCommentBelowLine lb = find commentOnLine where - commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) = - blockStart lb == start - 1 && blockEnd lb == end - 1 + getType = \case + HsIB _ tp -> tp + XHsImplicitBndrs x -> noExtCon x + + withinColumns PrinterState{currentLine} = + case cMaxColumns of + MaxColumns maxCols -> length currentLine <= maxCols + NoMaxColumns -> True + + oneLinePrint = do + space + putText "(" + sep + (comma >> space) + (fmap putOutputable tys) + putText ")" + + multilinePrint = do + newline + spaces indentation + putText "(" + + forM_ headTy \t -> + space >> putOutputable t + + forM_ tailTy \t -> do + newline + spaces indentation + comma + space + putOutputable t + + newline + spaces indentation + putText ")" + + indentation = + cDeriving + case cFirstField of + Indent x -> x + SameLine -> 0 + + tys + = clause + & deriv_clause_tys + & unLocated + & sortBy compareOutputable + & fmap hsib_body + + headTy = + listToMaybe tys + + tailTy = + drop 1 tys + +putUnbrokenEnum :: Config -> DataDecl -> P () +putUnbrokenEnum cfg decl = + sep + (space >> putText "|" >> space) + (fmap (putConstructor cfg 0) . dd_cons . dataDefn $ decl) + +putName :: DataDecl -> P () +putName decl@MkDataDecl{..} = + if isInfix decl then do + forM_ firstTvar (\t -> putOutputable t >> space) + putRdrName dataDeclName + space + forM_ secondTvar putOutputable + else do + putRdrName dataDeclName + forM_ (hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) -commentsWithin :: LineBlock -> [Comment] -> [Comment] -commentsWithin lb = filter within where - within (Comment _ (H.SrcSpan _ start _ end _) _) = - start >= blockStart lb && end <= blockEnd lb - -changeDecl :: [Comment] -> Config -> H.Decl LineBlock -> Maybe ChangeLine -changeDecl _ _ (H.DataDecl _ (H.DataType _) Nothing _ [] _) = Nothing -changeDecl allComments cfg@Config{..} (H.DataDecl block (H.DataType _) Nothing dhead decls derivings) - | hasRecordFields = Just $ change block (const $ concat newLines) - | otherwise = Nothing + firstTvar :: Maybe (Located (HsTyVarBndr GhcPs)) + firstTvar + = dataTypeVars + & hsq_explicit + & listToMaybe + + secondTvar :: Maybe (Located (HsTyVarBndr GhcPs)) + secondTvar + = dataTypeVars + & hsq_explicit + & drop 1 + & listToMaybe + +putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () +putConstructor cfg consIndent (L _ cons) = case cons of + ConDeclGADT{..} -> do + -- Put argument to constructor first: + case con_args of + PrefixCon _ -> do + sep + (comma >> space) + (fmap putRdrName con_names) + + InfixCon arg1 arg2 -> do + putType arg1 + space + forM_ con_names putRdrName + space + putType arg2 + RecCon _ -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putConstructor: " + , "encountered a GADT with record constructors, not supported yet" + ] + + -- Put type of constructor: + space + putText "::" + space + + when (unLocated con_forall) do + putText "forall" + space + sep space (fmap putOutputable $ hsq_explicit con_qvars) + dot + space + + forM_ con_mb_cxt (putContext cfg . unLocated) + putType con_res_ty + + XConDecl x -> + noExtCon x + ConDeclH98{..} -> + case con_args of + InfixCon arg1 arg2 -> do + putType arg1 + space + putRdrName con_name + space + putType arg2 + PrefixCon xs -> do + putRdrName con_name + unless (null xs) space + sep space (fmap putOutputable xs) + RecCon (L recPos (L posFirst firstArg : args)) -> do + putRdrName con_name + skipToBrace >> putText "{" + bracePos <- getCurrentLineLength + space + + -- Unless everything's configured to be on the same line, put pending + -- comments + unless (cFirstField cfg == SameLine) do + removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos + + -- Put first decl field + putConDeclField cfg firstArg + unless (cFirstField cfg == SameLine) (putEolComment posFirst) + + -- Put tail decl fields + forM_ args \(L pos arg) -> do + sepDecl bracePos + removeCommentTo pos >>= mapM_ \c -> + spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos + comma + space + putConDeclField cfg arg + putEolComment pos + + -- Print docstr after final field + removeCommentToEnd recPos >>= mapM_ \c -> + sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c + + -- Print whitespace to closing brace + sepDecl bracePos >> putText "}" + RecCon (L _ []) -> do + skipToBrace >> putText "{" + skipToBrace >> putText "}" + + where + skipToBrace = case (cEquals cfg, cFirstField cfg) of + (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y + (SameLine, SameLine) -> space + (Indent x, Indent y) -> newline >> spaces (x + y + 2) + (SameLine, Indent y) -> newline >> spaces (consIndent + y) + (Indent _, SameLine) -> space + + sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of + (_, Indent y) | not (cBreakSingleConstructors cfg) -> y + (SameLine, SameLine) -> bracePos - 1 -- back one from brace pos to place comma + (Indent x, Indent y) -> x + y + 2 + (SameLine, Indent y) -> bracePos - 1 + y - 2 + (Indent x, SameLine) -> bracePos - 1 + x - 2 + +putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () +putNewtypeConstructor cfg (L _ cons) = case cons of + ConDeclH98{..} -> + putRdrName con_name >> case con_args of + PrefixCon xs -> do + unless (null xs) space + sep space (fmap putOutputable xs) + RecCon (L _ [L _posFirst firstArg]) -> do + space + putText "{" + space + putConDeclField cfg firstArg + space + putText "}" + RecCon (L _ _args) -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "encountered newtype with several arguments" + ] + InfixCon {} -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "infix newtype constructor" + ] + XConDecl x -> + noExtCon x + ConDeclGADT{} -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "GADT encountered in newtype" + ] + +putContext :: Config -> HsContext GhcPs -> P () +putContext Config{..} = suffix (space >> putText "=>" >> space) . \case + [L _ (HsParTy _ tp)] | cCurriedContext -> + putType tp + [ctx] -> + putType ctx + ctxs | cCurriedContext -> + sep (space >> putText "=>" >> space) (fmap putType ctxs) + ctxs -> + parenthesize $ sep (comma >> space) (fmap putType ctxs) + +putConDeclField :: Config -> ConDeclField GhcPs -> P () +putConDeclField cfg = \case + ConDeclField{..} -> do + sep + (comma >> space) + (fmap putOutputable cd_fld_names) + space + putText "::" + space + putType' cfg cd_fld_type + XConDeclField{} -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putConDeclField: " + , "XConDeclField encountered" + ] + +-- | A variant of 'putType' that takes 'cCurriedContext' into account +putType' :: Config -> Located (HsType GhcPs) -> P () +putType' cfg = \case + L _ (HsForAllTy NoExtField vis bndrs tp) -> do + putText "forall" + space + sep space (fmap putOutputable bndrs) + putText + if vis == ForallVis then "->" + else "." + space + putType' cfg tp + L _ (HsQualTy NoExtField ctx tp) -> do + putContext cfg (unLocated ctx) + putType' cfg tp + other -> putType other + +newOrData :: DataDecl -> String +newOrData decl = if isNewtype decl then "newtype" else "data" + +isGADT :: DataDecl -> Bool +isGADT = any isGADTCons . dd_cons . dataDefn where - hasRecordFields = any - (\qual -> case qual of - (H.QualConDecl _ _ _ (H.RecDecl {})) -> True - _ -> False) - decls - - typeConstructor = "data " <> H.prettyPrint dhead - - -- In any case set @pipeIndent@ such that @|@ is aligned with @=@. - (firstLine, firstLineInit, pipeIndent) = - case cEquals of - SameLine -> (Nothing, typeConstructor <> " = ", length typeConstructor + 1) - Indent n -> (Just [[typeConstructor]], indent n "= ", n) - - newLines = fromMaybe [] firstLine ++ fmap constructors zipped <> [fmap (indent cDeriving . H.prettyPrint) derivings] - zipped = zip decls ([1..] ::[Int]) - - constructors (decl, 1) = processConstructor allComments firstLineInit cfg decl - constructors (decl, _) = processConstructor allComments (indent pipeIndent "| ") cfg decl -changeDecl _ _ _ = Nothing - -processConstructor :: [Comment] -> String -> Config -> H.QualConDecl LineBlock -> [String] -processConstructor allComments init Config{..} (H.QualConDecl _ _ _ (H.RecDecl _ dname (f:fs))) = do - fromMaybe [] firstLine <> n1 <> ns <> [indent fieldIndent "}"] + isGADTCons = \case + L _ (ConDeclGADT {}) -> True + _ -> False + +isNewtype :: DataDecl -> Bool +isNewtype = (== NewType) . dd_ND . dataDefn + +isInfix :: DataDecl -> Bool +isInfix = (== Infix) . dataFixity + +isEnum :: DataDecl -> Bool +isEnum = all isUnary . dd_cons . dataDefn where - n1 = processName firstLinePrefix (extractField f) - ns = fs >>= processName (indent fieldIndent ", ") . extractField - - -- Set @fieldIndent@ such that @,@ is aligned with @{@. - (firstLine, firstLinePrefix, fieldIndent) = - case cFirstField of - SameLine -> - ( Nothing - , init <> H.prettyPrint dname <> " { " - , length init + length (H.prettyPrint dname) + 1 - ) - Indent n -> - ( Just [init <> H.prettyPrint dname] - , indent (length init + n) "{ " - , length init + n - ) - - processName prefix (fnames, _type, lineComment, commentBelowLine) = - [prefix <> intercalate ", " (fmap H.prettyPrint fnames) <> " :: " <> H.prettyPrint _type <> addLineComment lineComment - ] ++ addCommentBelow commentBelowLine - - addLineComment (Just (Comment _ _ c)) = " --" <> c - addLineComment Nothing = "" - - -- Field comment indent is measured from the column with @{@, hence adding of @fieldIndent@ here. - addCommentBelow Nothing = [] - addCommentBelow (Just (Comment _ _ c)) = [indent (fieldIndent + cFieldComment) "--" <> c] - - extractField (H.FieldDecl lb names _type) = - (names, _type, findCommentOnLine lb allComments, findCommentBelowLine lb allComments) - -processConstructor _ init _ decl = [init <> trimLeft (H.prettyPrint decl)] + isUnary = \case + L _ (ConDeclH98 {..}) -> case con_args of + PrefixCon [] -> True + _ -> False + _ -> False + +hasConstructors :: DataDecl -> Bool +hasConstructors = not . null . dd_cons . dataDefn + +singleConstructor :: DataDecl -> Bool +singleConstructor = (== 1) . length . dd_cons . dataDefn + +hasDeriving :: DataDecl -> Bool +hasDeriving = not . null . unLocated . dd_derivs . dataDefn diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 7cb78d4..9c1d82d 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -1,61 +1,76 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Imports - ( Options (..) - , defaultOptions - , ImportAlign (..) - , ListAlign (..) - , LongListAlign (..) - , EmptyListAlign (..) - , ListPadding (..) - , step - ) where + ( Options (..) + , defaultOptions + , ImportAlign (..) + , ListAlign (..) + , LongListAlign (..) + , EmptyListAlign (..) + , ListPadding (..) + , step + ) where + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, when, void) +import Data.Function ((&), on) +import Data.Functor (($>)) +import Data.Foldable (toList) +import Data.Maybe (isJust) +import Data.List (sortBy) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set -------------------------------------------------------------------------------- -import Control.Arrow ((&&&)) -import Control.Monad (void) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A -import Data.Char (toLower) -import Data.List (intercalate, sortBy) -import qualified Data.Map as M -import Data.Maybe (isJust, maybeToList) -import Data.Ord (comparing) -import qualified Data.Set as S -import Data.Semigroup (Semigroup ((<>))) -import qualified Language.Haskell.Exts as H +import BasicTypes (StringLiteral (..), + SourceText (..)) +import qualified FastString as FS +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp +import Module (moduleNameString) +import RdrName (RdrName) +import SrcLoc (Located, GenLocated(..), unLoc) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Ordering +import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Util + -------------------------------------------------------------------------------- data Options = Options - { importAlign :: ImportAlign - , listAlign :: ListAlign - , padModuleNames :: Bool - , longListAlign :: LongListAlign - , emptyListAlign :: EmptyListAlign - , listPadding :: ListPadding - , separateLists :: Bool - , spaceSurround :: Bool + { importAlign :: ImportAlign + , listAlign :: ListAlign + , padModuleNames :: Bool + , longListAlign :: LongListAlign + , emptyListAlign :: EmptyListAlign + , listPadding :: ListPadding + , separateLists :: Bool + , spaceSurround :: Bool } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options - { importAlign = Global - , listAlign = AfterAlias - , padModuleNames = True - , longListAlign = Inline - , emptyListAlign = Inherit - , listPadding = LPConstant 4 - , separateLists = True - , spaceSurround = False + { importAlign = Global + , listAlign = AfterAlias + , padModuleNames = True + , longListAlign = Inline + , emptyListAlign = Inherit + , listPadding = LPConstant 4 + , separateLists = True + , spaceSurround = False } data ListPadding @@ -75,6 +90,7 @@ data ListAlign | WithModuleName | WithAlias | AfterAlias + | Repeat deriving (Eq, Show) data EmptyListAlign @@ -83,375 +99,382 @@ data EmptyListAlign deriving (Eq, Show) data LongListAlign - = Inline - | InlineWithBreak - | InlineToMultiline - | Multiline + = Inline -- inline + | InlineWithBreak -- new_line + | InlineToMultiline -- new_line_multiline + | Multiline -- multiline deriving (Eq, Show) -------------------------------------------------------------------------------- - -modifyImportSpecs :: ([H.ImportSpec l] -> [H.ImportSpec l]) - -> H.ImportDecl l -> H.ImportDecl l -modifyImportSpecs f imp = imp {H.importSpecs = f' <$> H.importSpecs imp} - where - f' (H.ImportSpecList l h specs) = H.ImportSpecList l h (f specs) - - --------------------------------------------------------------------------------- -imports :: H.Module l -> [H.ImportDecl l] -imports (H.Module _ _ _ is _) = is -imports _ = [] - - --------------------------------------------------------------------------------- -importName :: H.ImportDecl l -> String -importName i = let (H.ModuleName _ n) = H.importModule i in n - -importPackage :: H.ImportDecl l -> Maybe String -importPackage i = H.importPkg i - - --------------------------------------------------------------------------------- --- | A "compound import name" is import's name and package (if present). For --- instance, if you have an import @Foo.Bar@ from package @foobar@, the full --- name will be @"foobar" Foo.Bar@. -compoundImportName :: H.ImportDecl l -> String -compoundImportName i = - case importPackage i of - Nothing -> importName i - Just pkg -> show pkg ++ " " ++ importName i - - --------------------------------------------------------------------------------- -longestImport :: [H.ImportDecl l] -> Int -longestImport = maximum . map (length . compoundImportName) - - --------------------------------------------------------------------------------- --- | Compare imports for ordering -compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering -compareImports = - comparing (map toLower . importName &&& - fmap (map toLower) . importPackage &&& - H.importQualified) - - --------------------------------------------------------------------------------- --- | Remove (or merge) duplicated import specs. --- --- * When something is mentioned twice, it's removed: @A, A@ -> A --- * More general forms take priority: @A, A(..)@ -> @A(..)@ --- * Sometimes we have to combine imports: @A(x), A(y)@ -> @A(x, y)@ --- --- Import specs are always sorted by subsequent steps so we don't have to care --- about preserving order. -deduplicateImportSpecs :: Ord l => H.ImportDecl l -> H.ImportDecl l -deduplicateImportSpecs = - modifyImportSpecs $ - map recomposeImportSpec . - M.toList . M.fromListWith (<>) . - map decomposeImportSpec - --- | What we are importing (variable, class, etc) -data ImportEntity l - -- | A variable - = ImportVar l (H.Name l) - -- | Something that can be imported partially - | ImportClassOrData l (H.Name l) - -- | Something else ('H.IAbs') - | ImportOther l (H.Namespace l) (H.Name l) - deriving (Eq, Ord) - --- | What we are importing from an 'ImportClassOrData' -data ImportPortion l - = ImportSome [H.CName l] -- ^ @A(x, y, z)@ - | ImportAll -- ^ @A(..)@ - -instance Ord l => Semigroup (ImportPortion l) where - ImportSome a <> ImportSome b = ImportSome (setUnion a b) - _ <> _ = ImportAll - -instance Ord l => Monoid (ImportPortion l) where - mempty = ImportSome [] - mappend = (<>) - --- | O(n log n) union. -setUnion :: Ord a => [a] -> [a] -> [a] -setUnion a b = S.toList (S.fromList a `S.union` S.fromList b) - -decomposeImportSpec :: H.ImportSpec l -> (ImportEntity l, ImportPortion l) -decomposeImportSpec x = case x of - -- I checked and it looks like namespace's 'l' is always equal to x's 'l' - H.IAbs l space n -> case space of - H.NoNamespace _ -> (ImportClassOrData l n, ImportSome []) - H.TypeNamespace _ -> (ImportOther l space n, ImportSome []) - H.PatternNamespace _ -> (ImportOther l space n, ImportSome []) - H.IVar l n -> (ImportVar l n, ImportSome []) - H.IThingAll l n -> (ImportClassOrData l n, ImportAll) - H.IThingWith l n names -> (ImportClassOrData l n, ImportSome names) - -recomposeImportSpec :: (ImportEntity l, ImportPortion l) -> H.ImportSpec l -recomposeImportSpec (e, p) = case e of - ImportClassOrData l n -> case p of - ImportSome [] -> H.IAbs l (H.NoNamespace l) n - ImportSome names -> H.IThingWith l n names - ImportAll -> H.IThingAll l n - ImportVar l n -> H.IVar l n - ImportOther l space n -> H.IAbs l space n +step :: Maybe Int -> Options -> Step +step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- --- | The implementation is a bit hacky to get proper sorting for input specs: --- constructors first, followed by functions, and then operators. -compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering -compareImportSpecs = comparing key +printImports :: Maybe Int -> Options -> Lines -> Module -> Lines +printImports maxCols align ls m = applyChanges changes ls where - key :: H.ImportSpec l -> (Int, Bool, String) - key (H.IVar _ x) = (1, isOperator x, nameToString x) - key (H.IAbs _ _ x) = (0, False, nameToString x) - key (H.IThingAll _ x) = (0, False, nameToString x) - key (H.IThingWith _ x _) = (0, False, nameToString x) - + groups = moduleImportGroups m + moduleStats = foldMap importStats . fmap unLoc $ concatMap toList groups + changes = do + group <- groups + pure $ formatGroup maxCols align m moduleStats group + +formatGroup + :: Maybe Int -> Options -> Module -> ImportStats + -> NonEmpty (Located Import) -> Change String +formatGroup maxCols options m moduleStats imports = + let newLines = formatImports maxCols options m moduleStats imports in + change (importBlock imports) (const newLines) + +importBlock :: NonEmpty (Located a) -> Block String +importBlock group = Block + (getStartLineUnsafe $ NonEmpty.head group) + (getEndLineUnsafe $ NonEmpty.last group) + +formatImports + :: Maybe Int -- ^ Max columns. + -> Options -- ^ Options. + -> Module -- ^ Module. + -> ImportStats -- ^ Module stats. + -> NonEmpty (Located Import) -> Lines +formatImports maxCols options m moduleStats rawGroup = + runPrinter_ (PrinterConfig maxCols) [] m do + let + + group + = NonEmpty.sortWith unLocated rawGroup + & mergeImports + + unLocatedGroup = fmap unLocated $ toList group + + align' = importAlign options + padModuleNames' = padModuleNames options + padNames = align' /= None && padModuleNames' + + stats = case align' of + Global -> moduleStats {isAnyQualified = True} + File -> moduleStats + Group -> foldMap importStats unLocatedGroup + None -> mempty + + forM_ group \imp -> printQualified options padNames stats imp >> newline -------------------------------------------------------------------------------- --- | Sort the input spec list inside an 'H.ImportDecl' -sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l -sortImportSpecs = modifyImportSpecs (sortBy compareImportSpecs) +printQualified :: Options -> Bool -> ImportStats -> Located Import -> P () +printQualified Options{..} padNames stats (L _ decl) = do + let decl' = rawImport decl + + putText "import" >> space + + case (isSource decl, isAnySource stats) of + (True, _) -> putText "{-# SOURCE #-}" >> space + (_, True) -> putText " " >> space + _ -> pure () + + when (isSafe decl) (putText "safe" >> space) + + case (isQualified decl, isAnyQualified stats) of + (True, _) -> putText "qualified" >> space + (_, True) -> putText " " >> space + _ -> pure () + + moduleNamePosition <- length <$> getCurrentLine + forM_ (ideclPkgQual decl') $ \pkg -> putText (stringLiteral pkg) >> space + putText (moduleName decl) + + -- Only print spaces if something follows. + when padNames $ + when (isJust (ideclAs decl') || isHiding decl || + not (null $ ideclHiding decl')) $ + putText $ + replicate (isLongestImport stats - importModuleNameLength decl) ' ' + + beforeAliasPosition <- length <$> getCurrentLine + forM_ (ideclAs decl') \(L _ name) -> + space >> putText "as" >> space >> putText (moduleNameString name) + afterAliasPosition <- length <$> getCurrentLine + + when (isHiding decl) (space >> putText "hiding") + + let putOffset = putText $ replicate offset ' ' + offset = case listPadding of + LPConstant n -> n + LPModuleName -> moduleNamePosition + + case snd <$> ideclHiding decl' of + Nothing -> pure () + Just (L _ []) -> case emptyListAlign of + RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" + Inherit -> case listAlign of + NewLine -> + modifyCurrentLine trimRight >> newline >> putOffset >> putText "()" + _ -> space >> putText "()" + Just (L _ imports) -> do + let printedImports = flagEnds $ -- [P ()] + fmap ((printImport Options{..}) . unLocated) + (prepareImportList imports) + + -- Since we might need to output the import module name several times, we + -- need to save it to a variable: + wrapPrefix <- case listAlign of + AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' ' + WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' + Repeat -> fmap (++ " (") getCurrentLine + WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' + NewLine -> pure $ replicate offset ' ' + + let -- Helper + doSpaceSurround = when spaceSurround space + + -- Try to put everything on one line. + printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ putText "(" >> doSpaceSurround + imp + if end then doSpaceSurround >> putText ")" else comma >> space + + -- Try to put everything one by one, wrapping if that fails. + printAsInlineWrapping wprefix = forM_ printedImports $ + \(imp, start, end) -> + patchForRepeatHiding $ wrapping + (do + if start then putText "(" >> doSpaceSurround else space + imp + if end then doSpaceSurround >> putText ")" else comma) + (do + case listAlign of + -- In 'Repeat' mode, end lines with ')' rather than ','. + Repeat | not start -> modifyCurrentLine . withLast $ + \c -> if c == ',' then ')' else c + _ | start && spaceSurround -> + -- Only necessary if spaceSurround is enabled. + modifyCurrentLine trimRight + _ -> pure () + newline + void wprefix + case listAlign of + -- '(' already included in repeat + Repeat -> pure () + -- Print the much needed '(' + _ | start -> putText "(" >> doSpaceSurround + -- Don't bother aligning if we're not in inline mode. + _ | longListAlign /= Inline -> pure () + -- 'Inline + AfterAlias' is really where we want to be careful + -- with spacing. + AfterAlias -> space >> doSpaceSurround + WithModuleName -> pure () + WithAlias -> pure () + NewLine -> pure () + imp + if end then doSpaceSurround >> putText ")" else comma) + + -- Put everything on a separate line. 'spaceSurround' can be + -- ignored. + printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ modifyCurrentLine trimRight -- We added some spaces. + newline + putOffset + if start then putText "( " else putText ", " + imp + when end $ newline >> putOffset >> putText ")" + + case longListAlign of + Multiline -> wrapping + (space >> printAsSingleLine) + printAsMultiLine + Inline | NewLine <- listAlign -> do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) + Inline -> space >> printAsInlineWrapping (putText wrapPrefix) + InlineWithBreak -> wrapping + (space >> printAsSingleLine) + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping putOffset) + InlineToMultiline -> wrapping + (space >> printAsSingleLine) + (wrapping + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsSingleLine) + printAsMultiLine) + where + -- We cannot wrap/repeat 'hiding' imports since then we would get multiple + -- imports hiding different things. + patchForRepeatHiding = case listAlign of + Repeat | isHiding decl -> withColumns Nothing + _ -> id -------------------------------------------------------------------------------- --- | Order of imports in sublist is: --- Constructors, accessors/methods, operators. -compareImportSubSpecs :: H.CName l -> H.CName l -> Ordering -compareImportSubSpecs = comparing key - where - key :: H.CName l -> (Int, Bool, String) - key (H.ConName _ x) = (0, False, nameToString x) - key (H.VarName _ x) = (1, isOperator x, nameToString x) - +printImport :: Options -> IE GhcPs -> P () +printImport Options{..} (IEVar _ name) = do + printIeWrappedName name +printImport _ (IEThingAbs _ name) = do + printIeWrappedName name +printImport _ (IEThingAll _ name) = do + printIeWrappedName name + space + putText "(..)" +printImport _ (IEModuleContents _ (L _ m)) = do + putText (moduleNameString m) +printImport Options{..} (IEThingWith _ name _wildcard imps _) = do + printIeWrappedName name + when separateLists space + parenthesize $ + sep (comma >> space) (printIeWrappedName <$> imps) +printImport _ (IEGroup _ _ _ ) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" +printImport _ (IEDoc _ _) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" +printImport _ (IEDocNamed _ _) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" +printImport _ (XIE ext) = + GHC.noExtCon ext -------------------------------------------------------------------------------- --- | By default, haskell-src-exts pretty-prints --- --- > import Foo (Bar(..)) --- --- but we want --- --- > import Foo (Bar (..)) --- --- instead. -prettyImportSpec :: (Ord l) => Bool -> H.ImportSpec l -> String -prettyImportSpec separate = prettyImportSpec' +printIeWrappedName :: LIEWrappedName RdrName -> P () +printIeWrappedName lie = unLocated lie & \case + IEName n -> putRdrName n + IEPattern n -> putText "pattern" >> space >> putRdrName n + IEType n -> putText "type" >> space >> putRdrName n + +mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import) +mergeImports (x :| []) = x :| [] +mergeImports (h :| (t : ts)) + | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts) + | otherwise = h :| mergeImportsTail (t : ts) where - prettyImportSpec' (H.IThingAll _ n) = H.prettyPrint n ++ sep "(..)" - prettyImportSpec' (H.IThingWith _ n cns) = H.prettyPrint n - ++ sep "(" - ++ intercalate ", " - (map H.prettyPrint $ sortBy compareImportSubSpecs cns) - ++ ")" - prettyImportSpec' x = H.prettyPrint x + mergeImportsTail (x : y : ys) + | canMergeImport (unLocated x) (unLocated y) = mergeImportsTail ((mergeModuleImport x y) : ys) + | otherwise = x : mergeImportsTail (y : ys) + mergeImportsTail xs = xs - sep = if separate then (' ' :) else id +moduleName :: Import -> String +moduleName + = moduleNameString + . unLocated + . ideclName + . rawImport -------------------------------------------------------------------------------- -prettyImport :: (Ord l, Show l) => - Maybe Int -> Options -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] -prettyImport columns Options{..} padQualified padName longest imp - | (void `fmap` H.importSpecs imp) == emptyImportSpec = emptyWrap - | otherwise = case longListAlign of - Inline -> inlineWrap - InlineWithBreak -> longListWrapper inlineWrap inlineWithBreakWrap - InlineToMultiline -> longListWrapper inlineWrap inlineToMultilineWrap - Multiline -> longListWrapper inlineWrap multilineWrap - where - emptyImportSpec = Just (H.ImportSpecList () False []) - -- "import" + space + qualifiedLength has space in it. - listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding - where - qualifiedLength = - if null qualified then 0 else 1 + sum (map length qualified) - - longListWrapper shortWrap longWrap - | listAlign == NewLine - || length shortWrap > 1 - || exceedsColumns (length (head shortWrap)) - = longWrap - | otherwise = shortWrap - - emptyWrap = case emptyListAlign of - Inherit -> inlineWrap - RightAfter -> [paddedNoSpecBase ++ " ()"] - - inlineWrap = inlineWrapper - $ mapSpecs - $ withInit (++ ",") - . withHead (("(" ++ maybeSpace) ++) - . withLast (++ (maybeSpace ++ ")")) - - inlineWrapper = case listAlign of - NewLine -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding' - WithModuleName -> wrapMaybe columns paddedBase (withModuleNameBaseLength + 4) - WithAlias -> wrapMaybe columns paddedBase (inlineBaseLength + 1) - -- Add 1 extra space to ensure same padding as in original code. - AfterAlias -> withTail ((' ' : maybeSpace) ++) - . wrapMaybe columns paddedBase (afterAliasBaseLength + 1) - - inlineWithBreakWrap = paddedNoSpecBase : wrapRestMaybe columns listPadding' - ( mapSpecs - $ withInit (++ ",") - . withHead (("(" ++ maybeSpace) ++) - . withLast (++ (maybeSpace ++ ")"))) - - inlineToMultilineWrap - | length inlineWithBreakWrap > 2 - || any (exceedsColumns . length) (tail inlineWithBreakWrap) - = multilineWrap - | otherwise = inlineWithBreakWrap - - -- 'wrapRest 0' ensures that every item of spec list is on new line. - multilineWrap = paddedNoSpecBase : wrapRest 0 listPadding' - ( mapSpecs - ( withHead ("( " ++) - . withTail (", " ++)) - ++ closer) - where - closer = if null importSpecs - then [] - else [")"] - - paddedBase = base $ padImport $ compoundImportName imp - - paddedNoSpecBase = base $ padImportNoSpec $ compoundImportName imp - - padImport = if hasExtras && padName - then padRight longest - else id - - padImportNoSpec = if (isJust (H.importAs imp) || hasHiding) && padName - then padRight longest - else id - - base' baseName importAs hasHiding' = unwords $ concat $ - [ ["import"] - , source - , safe - , qualified - , [baseName] - , importAs - , hasHiding' - ] - - base baseName = base' baseName - ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] - ["hiding" | hasHiding] - - inlineBaseLength = length $ - base' (padImport $ compoundImportName imp) [] [] - - withModuleNameBaseLength = length $ base' "" [] [] - - afterAliasBaseLength = length $ base' (padImport $ compoundImportName imp) - ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] [] - - (hasHiding, importSpecs) = case H.importSpecs imp of - Just (H.ImportSpecList _ h l) -> (h, Just l) - _ -> (False, Nothing) - - hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) - - qualified - | H.importQualified imp = ["qualified"] - | padQualified = - if H.importSrc imp - then [] - else if H.importSafe imp - then [" "] - else [" "] - | otherwise = [] - - safe - | H.importSafe imp = ["safe"] - | otherwise = [] - - source - | H.importSrc imp = ["{-# SOURCE #-}"] - | otherwise = [] - - mapSpecs f = case importSpecs of - Nothing -> [] -- Import everything - Just [] -> ["()"] -- Instance only imports - Just is -> f $ map (prettyImportSpec separateLists) is - - maybeSpace = case spaceSurround of - True -> " " - False -> "" - - exceedsColumns i = case columns of - Nothing -> False -- No number exceeds a maximum column count of - -- Nothing, because there is no limit to exceed. - Just c -> i > c - +data ImportStats = ImportStats + { isLongestImport :: !Int + , isAnySource :: !Bool + , isAnyQualified :: !Bool + , isAnySafe :: !Bool + } --------------------------------------------------------------------------------- -prettyImportGroup :: Maybe Int -> Options -> Bool -> Int - -> [H.ImportDecl LineBlock] - -> Lines -prettyImportGroup columns align fileAlign longest imps = - concatMap (prettyImport columns align padQual padName longest') $ - sortBy compareImports imps - where - align' = importAlign align - padModuleNames' = padModuleNames align +instance Semigroup ImportStats where + l <> r = ImportStats + { isLongestImport = isLongestImport l `max` isLongestImport r + , isAnySource = isAnySource l || isAnySource r + , isAnyQualified = isAnyQualified l || isAnyQualified r + , isAnySafe = isAnySafe l || isAnySafe r + } - longest' = case align' of - Group -> longestImport imps - _ -> longest +instance Monoid ImportStats where + mappend = (<>) + mempty = ImportStats 0 False False False - padName = align' /= None && padModuleNames' +importStats :: Import -> ImportStats +importStats i = + ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) - padQual = case align' of - Global -> True - File -> fileAlign - Group -> any H.importQualified imps - None -> False +-- Computes length till module name, includes package name. +-- TODO: this should reuse code with the printer +importModuleNameLength :: Import -> Int +importModuleNameLength imp = + (case ideclPkgQual (rawImport imp) of + Nothing -> 0 + Just sl -> 1 + length (stringLiteral sl)) + + (length $ moduleName imp) -------------------------------------------------------------------------------- -step :: Maybe Int -> Options -> Step -step columns = makeStep "Imports" . step' columns +stringLiteral :: StringLiteral -> String +stringLiteral sl = case sl_st sl of + NoSourceText -> FS.unpackFS $ sl_fs sl + SourceText s -> s -------------------------------------------------------------------------------- -step' :: Maybe Int -> Options -> Lines -> Module -> Lines -step' columns align ls (module', _) = applyChanges - [ change block $ const $ - prettyImportGroup columns align fileAlign longest importGroup - | (block, importGroup) <- groups - ] - ls - where - imps = map (sortImportSpecs . deduplicateImportSpecs) $ - imports $ fmap linesFromSrcSpan module' - longest = longestImport imps - groups = groupAdjacent [(H.ann i, i) | i <- imps] - - fileAlign = case importAlign align of - File -> any H.importQualified imps - _ -> False +isQualified :: Import -> Bool +isQualified + = (/=) NotQualified + . ideclQualified + . rawImport + +isHiding :: Import -> Bool +isHiding + = maybe False fst + . ideclHiding + . rawImport + +isSource :: Import -> Bool +isSource + = ideclSource + . rawImport + +isSafe :: Import -> Bool +isSafe + = ideclSafe + . rawImport -------------------------------------------------------------------------------- -listPaddingValue :: Int -> ListPadding -> Int -listPaddingValue _ (LPConstant n) = n -listPaddingValue n LPModuleName = n +-- | Cleans up an import item list. +-- +-- * Sorts import items. +-- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))` +-- * Removes duplicates from import lists. +prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] +prepareImportList = + sortBy compareLIE . map (fmap prepareInner) . + concatMap (toList . snd) . Map.toAscList . mergeByName + where + mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) + mergeByName imports0 = Map.fromListWith + -- Note that ideally every NonEmpty will just have a single entry and we + -- will be able to merge everything into that entry. Exotic imports can + -- mess this up, though. So they end up in the tail of the list. + (\(x :| xs) (y :| ys) -> case ieMerge (unLocated x) (unLocated y) of + Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` + Nothing -> x :| (xs ++ y : ys)) + [(ieName $ unLocated imp, imp :| []) | imp <- imports0] + + prepareInner :: IE GhcPs -> IE GhcPs + prepareInner = \case + -- Simplify `A ()` to `A`. + IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n + IEThingWith x n w ns fs -> + IEThingWith x n w (sortBy (compareWrappedName `on` unLoc) ns) fs + ie -> ie + + -- Merge two import items, assuming they have the same name. + ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs) + ieMerge l@(IEVar _ _) _ = Just l + ieMerge _ r@(IEVar _ _) = Just r + ieMerge (IEThingAbs _ _) r = Just r + ieMerge l (IEThingAbs _ _) = Just l + ieMerge l@(IEThingAll _ _) _ = Just l + ieMerge _ r@(IEThingAll _ _) = Just r + ieMerge (IEThingWith x0 n0 w0 ns0 []) (IEThingWith _ _ w1 ns1 []) + | w0 /= w1 = Nothing + | otherwise = Just $ + -- TODO: sort the `ns0 ++ ns1`? + IEThingWith x0 n0 w0 (nubOn (unwrapName . unLoc) $ ns0 ++ ns1) [] + ieMerge _ _ = Nothing --------------------------------------------------------------------------------- -instance A.FromJSON ListPadding where - parseJSON (A.String "module_name") = return LPModuleName - parseJSON (A.Number n) | n' >= 1 = return $ LPConstant n' - where - n' = truncate n - parseJSON v = A.typeMismatch "'module_name' or >=1 number" v +-------------------------------------------------------------------------------- +nubOn :: Ord k => (a -> k) -> [a] -> [a] +nubOn f = go Set.empty + where + go _ [] = [] + go acc (x : xs) + | y `Set.member` acc = go acc xs + | otherwise = x : go (Set.insert y acc) xs + where + y = f x diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index c9d461f..ddfdeb0 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) , step @@ -8,13 +11,23 @@ module Language.Haskell.Stylish.Step.LanguagePragmas -------------------------------------------------------------------------------- +import Data.List.NonEmpty (NonEmpty, fromList, toList) import qualified Data.Set as S -import qualified Language.Haskell.Exts as H +import Data.Text (Text) +import qualified Data.Text as T + + +-------------------------------------------------------------------------------- +import qualified GHC.Hs as Hs +import SrcLoc (RealSrcSpan, realSrcSpanStart, + srcLocLine, srcSpanEndLine, + srcSpanStartLine) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util @@ -27,19 +40,6 @@ data Style deriving (Eq, Show) --------------------------------------------------------------------------------- -pragmas :: H.Module l -> [(l, [String])] -pragmas (H.Module _ _ ps _ _) = - [(l, map nameToString names) | H.LanguagePragma l names <- ps] -pragmas _ = [] - - --------------------------------------------------------------------------------- --- | The start of the first block -firstLocation :: [(Block a, [String])] -> Int -firstLocation = minimum . map (blockStart . fst) - - -------------------------------------------------------------------------------- verticalPragmas :: String -> Int -> Bool -> [String] -> Lines verticalPragmas lg longest align pragmas' = @@ -91,10 +91,10 @@ prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols ali -------------------------------------------------------------------------------- -- | Filter redundant (and duplicate) pragmas out of the groups. As a side -- effect, we also sort the pragmas in their group... -filterRedundant :: (String -> Bool) - -> [(l, [String])] - -> [(l, [String])] -filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) +filterRedundant :: (Text -> Bool) + -> [(l, NonEmpty Text)] + -> [(l, [Text])] +filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList) where filterRedundant' (l, xs) (known, zs) | S.null xs' = (known', zs) @@ -111,38 +111,54 @@ step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' -------------------------------------------------------------------------------- step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines -step' columns style align removeRedundant lngPrefix ls (module', _) - | null pragmas' = ls - | otherwise = applyChanges changes ls +step' columns style align removeRedundant lngPrefix ls m + | null languagePragmas = ls + | otherwise = applyChanges changes ls where isRedundant' - | removeRedundant = isRedundant module' + | removeRedundant = isRedundant m | otherwise = const False - pragmas' = pragmas $ fmap linesFromSrcSpan module' - longest = maximum $ map length $ snd =<< pragmas' - groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] - changes = - [ change b (const $ prettyPragmas lngPrefix columns longest align style pg) - | (b, pg) <- filterRedundant isRedundant' groups - ] + languagePragmas = moduleLanguagePragmas m + + convertFstToBlock :: [(RealSrcSpan, a)] -> [(Block String, a)] + convertFstToBlock = fmap \(rspan, a) -> + (Block (srcSpanStartLine rspan) (srcSpanEndLine rspan), a) + + groupAdjacent' = + fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList) + where + turnSndBackToNel (a, bss) = (a, fromList . concat $ bss) + + longest :: Int + longest = maximum $ map T.length $ toList . snd =<< languagePragmas + + groups :: [(Block String, NonEmpty Text)] + groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] + + changes = + [ change b (const $ prettyPragmas lngPrefix columns longest align style (fmap T.unpack pg)) + | (b, pg) <- filterRedundant isRedundant' groups + ] -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. -addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String] +addLanguagePragma :: String -> String -> Module -> [Change String] addLanguagePragma lg prag modu | prag `elem` present = [] | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where - pragmas' = pragmas (fmap linesFromSrcSpan modu) - present = concatMap snd pragmas' - line = if null pragmas' then 1 else firstLocation pragmas' + pragmas' = moduleLanguagePragmas modu + present = concatMap ((fmap T.unpack) . toList . snd) pragmas' + line = if null pragmas' then 1 else firstLocation pragmas' + firstLocation :: [(RealSrcSpan, NonEmpty Text)] -> Int + firstLocation = minimum . fmap (srcLocLine . realSrcSpanStart . fst) -------------------------------------------------------------------------------- -- | Check if a language pragma is redundant. We can't do this for all pragmas, -- but we do a best effort. -isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool +isRedundant :: Module -> Text -> Bool isRedundant m "ViewPatterns" = isRedundantViewPatterns m isRedundant m "BangPatterns" = isRedundantBangPatterns m isRedundant _ _ = False @@ -150,13 +166,29 @@ isRedundant _ _ = False -------------------------------------------------------------------------------- -- | Check if the ViewPatterns language pragma is redundant. -isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantViewPatterns m = null - [() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]] +isRedundantViewPatterns :: Module -> Bool +isRedundantViewPatterns = null . queryModule getViewPat + where + getViewPat :: Hs.Pat Hs.GhcPs -> [()] + getViewPat = \case + Hs.ViewPat{} -> [()] + _ -> [] -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant. -isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantBangPatterns m = null - [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] +isRedundantBangPatterns :: Module -> Bool +isRedundantBangPatterns modul = + (null $ queryModule getBangPat modul) && + (null $ queryModule getMatchStrict modul) + where + getBangPat :: Hs.Pat Hs.GhcPs -> [()] + getBangPat = \case + Hs.BangPat{} -> [()] + _ -> [] + + getMatchStrict :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [()] + getMatchStrict (Hs.XMatch m) = Hs.noExtCon m + getMatchStrict (Hs.Match _ ctx _ _) = case ctx of + Hs.FunRhs _ _ Hs.SrcStrict -> [()] + _ -> [] diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs new file mode 100644 index 0000000..90f3478 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Step.ModuleHeader + ( Config (..) + , defaultConfig + , step + ) where + +-------------------------------------------------------------------------------- +import ApiAnnotation (AnnKeywordId (..), + AnnotationComment (..)) +import Control.Monad (forM_, join, when) +import Data.Bifunctor (second) +import Data.Foldable (find, toList) +import Data.Function (on, (&)) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust, listToMaybe) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp (IE (..)) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (GenLocated (..), Located, + RealLocated, SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine, unLoc) +import Util (notNull) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Ordering +import Language.Haskell.Stylish.Printer +import Language.Haskell.Stylish.Step + + +data Config = Config + -- TODO(jaspervdj): Use the same sorting as in `Imports`? + -- TODO: make sorting optional? + { indent :: Int + , sort :: Bool + } + +defaultConfig :: Config +defaultConfig = Config + { indent = 4 + , sort = True + } + +step :: Config -> Step +step = makeStep "Module header" . printModuleHeader + +printModuleHeader :: Config -> Lines -> Module -> Lines +printModuleHeader conf ls m = + let + header = moduleHeader m + name = rawModuleName header + haddocks = rawModuleHaddocks header + exports = rawModuleExports header + annotations = rawModuleAnnotations m + + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropAfterLocated exports + & dropBeforeLocated name + + -- TODO: pass max columns? + printedModuleHeader = runPrinter_ (PrinterConfig Nothing) relevantComments + m (printHeader conf name exports haddocks) + + getBlock loc = + Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc + + adjustOffsetFrom :: Block a -> Block a -> Maybe (Block a) + adjustOffsetFrom (Block s0 _) b2@(Block s1 e1) + | s0 >= s1 && s0 >= e1 = Nothing + | s0 >= s1 = Just (Block (s0 + 1) e1) + | otherwise = Just b2 + + nameBlock = + getBlock name + + exportsBlock = + join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports + + whereM :: Maybe SrcSpan + whereM + = annotations + & filter (\(((_, w), _)) -> w == AnnWhere) + & fmap (head . snd) -- get position of annot + & L.sort + & listToMaybe + + isModuleHeaderWhere :: Block a -> Bool + isModuleHeaderWhere w + = not + . overlapping + $ [w] <> toList nameBlock <> toList exportsBlock + + toLineBlock :: SrcSpan -> Block a + toLineBlock (RealSrcSpan s) = Block (srcSpanStartLine s) (srcSpanEndLine s) + toLineBlock s + = error + $ "'where' block was not a RealSrcSpan" <> show s + + whereBlock + = whereM + & fmap toLineBlock + & find isModuleHeaderWhere + + deletes = + fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock + + startLine = + maybe 1 blockStart nameBlock + + additions = [insert startLine printedModuleHeader] + + changes = deletes <> additions + in + applyChanges changes ls + +printHeader + :: Config + -> Maybe (Located GHC.ModuleName) + -> Maybe (Located [GHC.LIE GhcPs]) + -> Maybe GHC.LHsDocString + -> P () +printHeader conf mname mexps _ = do + forM_ mname \(L loc name) -> do + putText "module" + space + putText (showOutputable name) + attachEolComment loc + + maybe + (when (isJust mname) do newline >> spaces (indent conf) >> putText "where") + (printExportList conf) + mexps + +attachEolComment :: SrcSpan -> P () +attachEolComment = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanStartLine rspan) >>= mapM_ \c -> space >> putComment c + +attachEolCommentEnd :: SrcSpan -> P () +attachEolCommentEnd = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanEndLine rspan) >>= mapM_ \c -> space >> putComment c + +printExportList :: Config -> Located [GHC.LIE GhcPs] -> P () +printExportList conf (L srcLoc exports) = do + newline + doIndent >> putText "(" >> when (notNull exports) space + + exportsWithComments <- fmap (second doSort) <$> groupAttachedComments exports + + printExports exportsWithComments + + putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc + where + -- 'doIndent' is @x@: + -- + -- > module Foo + -- > xxxx( foo + -- > xxxx, bar + -- > xxxx) where + -- + -- 'doHang' is @y@: + -- + -- > module Foo + -- > xxxx( -- Some comment + -- > xxxxyyfoo + -- > xxxx) where + doIndent = spaces (indent conf) + doHang = do + len <- length <$> getCurrentLine + spaces $ indent conf + 2 - len + + doSort = if sort conf then NonEmpty.sortBy compareLIE else id + + printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () + printExports (([], firstInGroup :| groupRest) : rest) = do + printExport firstInGroup + newline + doIndent + printExportsGroupTail groupRest + printExportsTail rest + printExports ((firstComment : comments, firstExport :| groupRest) : rest) = do + putComment firstComment >> newline >> doIndent + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent + doHang + printExport firstExport + newline + doIndent + printExportsGroupTail groupRest + printExportsTail rest + printExports [] = + newline >> doIndent + + printExportsTail :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () + printExportsTail = mapM_ \(comments, exported) -> do + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent + forM_ exported \export -> do + comma >> space >> printExport export + newline >> doIndent + + printExportsGroupTail :: [GHC.LIE GhcPs] -> P () + printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] + printExportsGroupTail [] = pure () + + printExport :: GHC.LIE GhcPs -> P () + printExport (L _ export) = case export of + IEVar _ name -> putOutputable name + IEThingAbs _ name -> putOutputable name + IEThingAll _ name -> do + putOutputable name + space + putText "(..)" + IEModuleContents _ (L _ m) -> do + putText "module" + space + putText (showOutputable m) + IEThingWith _ name _wildcard imps _ -> do + putOutputable name + space + putText "(" + sep (comma >> space) $ + fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps + putText ")" + IEGroup _ _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export + IEDoc _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export + IEDocNamed _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export + XIE ext -> + GHC.noExtCon ext diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 5e61123..e02c270 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , defaultConfig @@ -7,15 +8,17 @@ module Language.Haskell.Stylish.Step.SimpleAlign -------------------------------------------------------------------------------- -import Data.Data (Data) +import Control.Monad (guard) import Data.List (foldl') -import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts as H +import Data.Maybe (fromMaybe) +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Align import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util @@ -38,91 +41,111 @@ defaultConfig = Config -------------------------------------------------------------------------------- -cases :: Data l => H.Module l -> [[H.Alt l]] -cases modu = [alts | H.Case _ _ alts <- everything modu] +type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] -------------------------------------------------------------------------------- --- | For this to work well, we require a way to merge annotations. This merge --- operation should follow the semigroup laws. -altToAlignable :: (l -> l -> l) -> H.Alt l -> Maybe (Alignable l) -altToAlignable _ (H.Alt _ _ _ (Just _)) = Nothing -altToAlignable _ (H.Alt ann pat rhs@(H.UnGuardedRhs _ _) Nothing) = Just $ - Alignable - { aContainer = ann - , aLeft = H.ann pat - , aRight = H.ann rhs - , aRightLead = length "-> " - } -altToAlignable - merge - (H.Alt ann pat (H.GuardedRhss _ [H.GuardedRhs _ guards rhs]) Nothing) = - -- We currently only support the case where an alternative has a single - -- guarded RHS. If there are more, we would need to return multiple - -- `Alignable`s from this function, which would be a significant change. - Just $ Alignable - { aContainer = ann - , aLeft = foldl' merge (H.ann pat) (map H.ann guards) - , aRight = H.ann rhs - , aRightLead = length "-> " - } -altToAlignable _ _ = Nothing +records :: S.Located (Hs.HsModule Hs.GhcPs) -> [Record] +records modu = do + let decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) + tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] + dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] + dataDefns = map Hs.tcdDataDefn dataDecls + d@Hs.ConDeclH98 {} <- concatMap getConDecls dataDefns + case Hs.con_args d of + Hs.RecCon rec -> [S.unLoc rec] + _ -> [] + where + getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] + getConDecls d@Hs.HsDataDefn {} = map S.unLoc $ Hs.dd_cons d + getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x -------------------------------------------------------------------------------- -tlpats :: Data l => H.Module l -> [[H.Match l]] -tlpats modu = [matches | H.FunBind _ matches <- everything modu] +recordToAlignable :: Record -> [Alignable S.RealSrcSpan] +recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- -matchToAlignable :: H.Match l -> Maybe (Alignable l) -matchToAlignable (H.InfixMatch _ _ _ _ _ _) = Nothing -matchToAlignable (H.Match _ _ [] _ _) = Nothing -matchToAlignable (H.Match _ _ _ _ (Just _)) = Nothing -matchToAlignable (H.Match ann name pats rhs Nothing) = Just $ Alignable - { aContainer = ann - , aLeft = last (H.ann name : map H.ann pats) - , aRight = H.ann rhs - , aRightLead = length "= " +fieldDeclToAlignable + :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan) +fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x +fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan $ S.getLoc $ last names + tyPos <- toRealSrcSpan $ S.getLoc ty + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = tyPos + , aRightLead = length ":: " } -------------------------------------------------------------------------------- -records :: H.Module l -> [[H.FieldDecl l]] -records modu = - [ fields - | H.Module _ _ _ _ decls <- [modu] - , H.DataDecl _ _ _ _ cons _ <- decls - , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons - ] +matchGroupToAlignable + :: Config + -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) + -> [Alignable S.RealSrcSpan] +matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x +matchGroupToAlignable conf (Hs.MG _ alts _) = + fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts) -------------------------------------------------------------------------------- -fieldDeclToAlignable :: H.FieldDecl a -> Maybe (Alignable a) -fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable - { aContainer = ann - , aLeft = H.ann (last names) - , aRight = H.ann ty - , aRightLead = length ":: " +matchToAlignable + :: Config + -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable S.RealSrcSpan) +matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + let patsLocs = map S.getLoc pats + pat = last patsLocs + guards = getGuards m + guardsLocs = map S.getLoc guards + left = foldl' S.combineSrcSpans pat guardsLocs + guard $ cCases conf + body <- rhsBody grhss + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + rightPos <- toRealSrcSpan $ S.getLoc body + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = rightPos + , aRightLead = length "-> " } +matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do + guard $ cTopLevelPatterns conf + body <- unguardedRhsBody grhss + let patsLocs = map S.getLoc pats + nameLoc = S.getLoc name + left = last (nameLoc : patsLocs) + bodyLoc = S.getLoc body + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos + , aRightLead = length "= " + } +matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' - changes search toAlign = - [ change_ - | case_ <- search module'' - , aligns <- maybeToList (mapM toAlign case_) - , change_ <- align maxColumns aligns - ] - +step maxColumns config = makeStep "Cases" $ \ls module' -> + let changes + :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) + -> (a -> [Alignable S.RealSrcSpan]) + -> [Change String] + changes search toAlign = concat $ + map (align maxColumns) . map toAlign $ search (parsedModule module') + + configured :: [Change String] configured = concat $ - [ changes cases (altToAlignable H.mergeSrcSpan) - | cCases config - ] ++ - [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ - [changes records fieldDeclToAlignable | cRecords config] - - in applyChanges configured ls + [changes records recordToAlignable | cRecords config] ++ + [changes everything (matchGroupToAlignable config)] in + applyChanges configured ls diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 0eb4895..23d1e9f 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.Squash ( step ) where @@ -6,7 +9,8 @@ module Language.Haskell.Stylish.Step.Squash -------------------------------------------------------------------------------- import Data.Maybe (mapMaybe) -import qualified Language.Haskell.Exts as H +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -17,46 +21,43 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- squash - :: (H.Annotated l, H.Annotated r) - => l H.SrcSpan -> r H.SrcSpan -> Maybe (Change String) -squash left right - | H.srcSpanEndLine lAnn == H.srcSpanStartLine rAnn = Just $ - changeLine (H.srcSpanEndLine lAnn) $ \str -> - let (pre, post) = splitAt (H.srcSpanEndColumn lAnn) str - in [trimRight pre ++ " " ++ trimLeft post] - | otherwise = Nothing - where - lAnn = H.ann left - rAnn = H.ann right - - --------------------------------------------------------------------------------- -squashFieldDecl :: H.FieldDecl H.SrcSpan -> Maybe (Change String) -squashFieldDecl (H.FieldDecl _ names type') + :: (S.HasSrcSpan l, S.HasSrcSpan r) + => l -> r -> Maybe (Change String) +squash left right = do + lAnn <- toRealSrcSpan $ S.getLoc left + rAnn <- toRealSrcSpan $ S.getLoc right + if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn || + S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn + then Just $ + changeLine (S.srcSpanEndLine lAnn) $ \str -> + let (pre, post) = splitAt (S.srcSpanEndCol lAnn) str + in [trimRight pre ++ " " ++ trimLeft post] + else Nothing + + +-------------------------------------------------------------------------------- +squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String) +squashFieldDecl (Hs.ConDeclField _ names type' _) | null names = Nothing | otherwise = squash (last names) type' +squashFieldDecl (Hs.XConDeclField x) = Hs.noExtCon x -------------------------------------------------------------------------------- -squashMatch :: H.Match H.SrcSpan -> Maybe (Change String) -squashMatch (H.InfixMatch _ _ _ _ _ _) = Nothing -squashMatch (H.Match _ name pats rhs _) - | null pats = squash name rhs - | otherwise = squash (last pats) rhs - - --------------------------------------------------------------------------------- -squashAlt :: H.Alt H.SrcSpan -> Maybe (Change String) -squashAlt (H.Alt _ pat rhs _) = squash pat rhs +squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String) +squashMatch (Hs.Match _ (Hs.FunRhs name _ _) [] grhss) = do + body <- unguardedRhsBody grhss + squash name body +squashMatch (Hs.Match _ _ pats grhss) = do + body <- unguardedRhsBody grhss + squash (last pats) body +squashMatch (Hs.XMatch x) = Hs.noExtCon x -------------------------------------------------------------------------------- step :: Step -step = makeStep "Squash" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' - changes = concat - [ mapMaybe squashAlt (everything module'') - , mapMaybe squashMatch (everything module'') - , mapMaybe squashFieldDecl (everything module'') - ] - in applyChanges changes ls +step = makeStep "Squash" $ \ls (module') -> + let changes = + mapMaybe squashFieldDecl (everything module') ++ + mapMaybe squashMatch (everything module') in + applyChanges changes ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 266e8e5..2f0def6 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -10,17 +10,17 @@ import Data.List (isPrefixOf, import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts as H - - +import GHC.Hs.Binds +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Types -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import Language.Haskell.Stylish.Util - -------------------------------------------------------------------------------- unicodeReplacements :: Map String String unicodeReplacements = M.fromList @@ -39,7 +39,7 @@ replaceAll :: [(Int, [(Int, String)])] -> [Change String] replaceAll = map changeLine' where changeLine' (r, ns) = changeLine r $ \str -> return $ - applyChanges + applyChanges [ change (Block c ec) (const repl) | (c, needle) <- sort ns , let ec = c + length needle - 1 @@ -54,33 +54,32 @@ groupPerLine = M.toList . M.fromListWith (++) . -------------------------------------------------------------------------------- -typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeSigs :: Module -> Lines -> [((Int, Int), String)] typeSigs module' ls = [ (pos, "::") - | H.TypeSig loc _ _ <- everything module' :: [H.Decl H.SrcSpanInfo] - , (start, end) <- infoPoints loc - , pos <- maybeToList $ between start end "::" ls + | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (_, funEnd) <- infoPoints funLoc + , (typeStart, _) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between funEnd typeStart "::" ls ] - -------------------------------------------------------------------------------- -contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +contexts :: Module -> Lines -> [((Int, Int), String)] contexts module' ls = [ (pos, "=>") - | context <- everything module' :: [H.Context H.SrcSpanInfo] - , (start, end) <- infoPoints $ H.ann context - , pos <- maybeToList $ between start end "=>" ls + | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (start, end) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between start end "=>" ls ] -------------------------------------------------------------------------------- -typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeFuns :: Module -> Lines -> [((Int, Int), String)] typeFuns module' ls = [ (pos, "->") - | H.TyFun _ t1 t2 <- everything module' - , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1 - , let end = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2 - , pos <- maybeToList $ between start end "->" ls + | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (start, end) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between start end "->" ls ] @@ -110,7 +109,7 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' alp lg ls (module', _) = applyChanges changes ls +step' alp lg ls module' = applyChanges changes ls where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ replaceAll perLine diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 9883f4b..90bea63 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,8 +1,8 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util - ( nameToString - , isOperator - , indent + ( indent , padRight , everything , infoPoints @@ -13,40 +13,41 @@ module Language.Haskell.Stylish.Util , wrapMaybe , wrapRestMaybe + -- * Extra list functions , withHead , withInit , withTail , withLast + , flagEnds + + , toRealSrcSpan + + , traceOutputtable + , traceOutputtableM + + , unguardedRhsBody + , rhsBody + + , getGuards ) where -------------------------------------------------------------------------------- -import Control.Arrow ((&&&), (>>>)) -import Data.Char (isAlpha, isSpace) +import Data.Char (isSpace) import Data.Data (Data) import qualified Data.Generics as G -import Data.Maybe (fromMaybe, listToMaybe, - maybeToList) +import Data.Maybe (maybeToList) import Data.Typeable (cast) -import qualified Language.Haskell.Exts as H +import Debug.Trace (trace) +import qualified GHC.Hs as Hs +import qualified Outputable +import qualified SrcLoc as S -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step --------------------------------------------------------------------------------- -nameToString :: H.Name l -> String -nameToString (H.Ident _ str) = str -nameToString (H.Symbol _ str) = str - - --------------------------------------------------------------------------------- -isOperator :: H.Name l -> Bool -isOperator = fromMaybe False - . (fmap (not . isAlpha) . listToMaybe) - . nameToString - -------------------------------------------------------------------------------- indent :: Int -> String -> String indent len = (indentPrefix len ++) @@ -68,8 +69,16 @@ everything = G.everything (++) (maybeToList . cast) -------------------------------------------------------------------------------- -infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] -infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd) +infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))] +infoPoints = fmap (helper . S.getLoc) + where + helper :: S.SrcSpan -> ((Int, Int), (Int, Int)) + helper (S.RealSrcSpan s) = do + let + start = S.realSrcSpanStart s + end = S.realSrcSpanEnd s + ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end)) + helper _ = ((-1,-1), (-1,-1)) -------------------------------------------------------------------------------- @@ -117,7 +126,7 @@ noWrap :: String -- ^ Leading string -> Lines -- ^ Resulting lines noWrap leading _ind = noWrap' leading where - noWrap' ss [] = [ss] + noWrap' ss [] = [ss] noWrap' ss (str:strs) = noWrap' (ss ++ " " ++ str) strs @@ -181,7 +190,78 @@ withInit _ [] = [] withInit _ [x] = [x] withInit f (x : xs) = f x : withInit f xs + -------------------------------------------------------------------------------- withTail :: (a -> a) -> [a] -> [a] withTail _ [] = [] withTail f (x : xs) = x : map f xs + + + +-------------------------------------------------------------------------------- +-- | Utility for traversing through a list and knowing when you're at the +-- first and last element. +flagEnds :: [a] -> [(a, Bool, Bool)] +flagEnds = \case + [] -> [] + [x] -> [(x, True, True)] + x : y : zs -> (x, True, False) : go (y : zs) + where + go (x : y : zs) = (x, False, False) : go (y : zs) + go [x] = [(x, False, True)] + go [] = [] + + +-------------------------------------------------------------------------------- +traceOutputtable :: Outputable.Outputable a => String -> a -> b -> b +traceOutputtable title x = + trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x)) + + +-------------------------------------------------------------------------------- +traceOutputtableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () +traceOutputtableM title x = traceOutputtable title x $ pure () + + +-------------------------------------------------------------------------------- +-- take the (Maybe) RealSrcSpan out of the SrcSpan +toRealSrcSpan :: S.SrcSpan -> Maybe S.RealSrcSpan +toRealSrcSpan (S.RealSrcSpan s) = Just s +toRealSrcSpan _ = Nothing + + +-------------------------------------------------------------------------------- +-- Utility: grab the body out of guarded RHSs if it's a single unguarded one. +unguardedRhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a +unguardedRhsBody (Hs.GRHSs _ [grhs] _) + | Hs.GRHS _ [] body <- S.unLoc grhs = Just body +unguardedRhsBody _ = Nothing + + +-- Utility: grab the body out of guarded RHSs +rhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a +rhsBody (Hs.GRHSs _ [grhs] _) + | Hs.GRHS _ _ body <- S.unLoc grhs = Just body +rhsBody _ = Nothing + + +-------------------------------------------------------------------------------- +-- get guards in a guarded rhs of a Match +getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] +getGuards (Hs.Match _ _ _ grhss) = + let + lgrhs = getLocGRHS grhss -- [] + grhs = map S.unLoc lgrhs + in + concatMap getGuardLStmts grhs +getGuards (Hs.XMatch x) = Hs.noExtCon x + + +getLocGRHS :: Hs.GRHSs Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.LGRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] +getLocGRHS (Hs.GRHSs _ guardeds _) = guardeds +getLocGRHS (Hs.XGRHSs x) = Hs.noExtCon x + + +getGuardLStmts :: Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] +getGuardLStmts (Hs.GRHS _ guards _) = guards +getGuardLStmts (Hs.XGRHS x) = Hs.noExtCon x diff --git a/src/Main.hs b/src/Main.hs index b1ca2d5..a41c1d8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Main ( main @@ -5,15 +6,18 @@ module Main -------------------------------------------------------------------------------- -import Control.Monad (forM_, unless) +import Control.Monad (forM_, unless, when) import qualified Data.ByteString.Char8 as BC8 -import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified Options.Applicative as OA import System.Exit (exitFailure) import qualified System.IO as IO import qualified System.IO.Strict as IO.Strict +-------------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ < 808 +import Data.Monoid ((<>)) +#endif -------------------------------------------------------------------------------- import Language.Haskell.Stylish @@ -112,7 +116,10 @@ stylishHaskell sa = do forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" verbose' $ "Extra language extensions: " ++ show (configLanguageExtensions conf) - mapM_ (file sa conf) $ files' filesR + res <- foldMap (file sa conf) (files' filesR) + + verbose' $ "Exit code behavior: " ++ show (configExitCode conf) + when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat) exitFailure where verbose' = makeVerbose (saVerbose sa) files' x = case (saRecursive sa, null x) of @@ -120,16 +127,33 @@ stylishHaskell sa = do (_,True) -> [Nothing] -- Involving IO.stdin. (_,False) -> map Just x -- Process available files. +data FormattingResult + = DidFormat + | NoChange + deriving (Eq) + +instance Semigroup FormattingResult where + _ <> DidFormat = DidFormat + DidFormat <> _ = DidFormat + _ <> _ = NoChange + +instance Monoid FormattingResult where + mempty = NoChange -------------------------------------------------------------------------------- -- | Processes a single file, or stdin if no filepath is given -file :: StylishArgs -> Config -> Maybe FilePath -> IO () +file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult file sa conf mfp = do contents <- maybe getContents readUTF8File mfp - let result = runSteps (configLanguageExtensions conf) - mfp (configSteps conf) $ lines contents + let + inputLines = + lines contents + result = + runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines case result of - Right ok -> write contents $ unlines ok + Right ok -> do + write contents (unlines ok) + pure $ if ok /= inputLines then DidFormat else NoChange Left err -> do IO.hPutStrLn IO.stderr err exitFailure diff --git a/stack.yaml b/stack.yaml index 3b76264..c843225 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,7 @@ resolver: lts-16.9 extra-deps: +- 'ghc-lib-parser-8.10.1.20200324' - 'aeson-1.5.2.0' - 'Cabal-3.2.0.0' - 'HsYAML-aeson-0.2.0.0@rev:2' diff --git a/stack.yaml.lock b/stack.yaml.lock index 36c1629..3b36748 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,13 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: ghc-lib-parser-8.10.1.20200324@sha256:6a0b014e97f627dd9ca177f26f184e2f2ff713ec1271045334ccb56ac7bfdff3,9116 + pantry-tree: + size: 19497 + sha256: ba6d7c3a2c3517b1a1f25daa04446209137a38e39b35367ffb13bbb2a0a7be4e + original: + hackage: ghc-lib-parser-8.10.1.20200324 - completed: hackage: aeson-1.5.2.0@sha256:d00c7aa51969b2849550e4dee14c9ce188504d55ed8d7f734ce9f6976db452f6,6786 pantry-tree: diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 228cab5..cb1f6a1 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -30,8 +30,12 @@ Library Exposed-modules: Language.Haskell.Stylish + Language.Haskell.Stylish.GHC + Language.Haskell.Stylish.Module + Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports + Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.SimpleAlign Language.Haskell.Stylish.Step.Squash @@ -46,6 +50,7 @@ Library Language.Haskell.Stylish.Config.Cabal Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Ordering Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Step Language.Haskell.Stylish.Util @@ -61,13 +66,13 @@ Library directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, text >= 1.2 && < 1.3, HsYAML-aeson >=0.2.0 && < 0.3, HsYAML >=0.2.0 && < 0.3 - + if impl(ghc < 8.0) Build-depends: semigroups >= 0.18 && < 0.20 @@ -91,7 +96,7 @@ Executable stylish-haskell directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, HsYAML-aeson >=0.2.0 && < 0.3, @@ -113,13 +118,20 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.GHC + Language.Haskell.Stylish.Ordering + Language.Haskell.Stylish.Module Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests + Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.Imports.Tests + Language.Haskell.Stylish.Step.Imports.FelixTests Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Data.Tests + Language.Haskell.Stylish.Step.ModuleHeader + Language.Haskell.Stylish.Step.ModuleHeader.Tests Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.LanguagePragmas.Tests Language.Haskell.Stylish.Step.SimpleAlign @@ -152,7 +164,7 @@ Test-suite stylish-haskell-tests directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, text >= 1.2 && < 1.3, diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs index a8b2ee2..73062ab 100644 --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -153,6 +153,7 @@ dotStylish = unlines $ , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 4" + , " via: \"indent 2\"" , "columns: 110" , "language_extensions:" , " - TemplateHaskell" diff --git a/tests/Language/Haskell/Stylish/Parse/Tests.hs b/tests/Language/Haskell/Stylish/Parse/Tests.hs index a8ebf39..d46f4a5 100644 --- a/tests/Language/Haskell/Stylish/Parse/Tests.hs +++ b/tests/Language/Haskell/Stylish/Parse/Tests.hs @@ -6,7 +6,8 @@ module Language.Haskell.Stylish.Parse.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) +import Test.HUnit (Assertion, assertFailure) +import GHC.Stack (HasCallStack, withFrozenCallStack) -------------------------------------------------------------------------------- @@ -33,18 +34,18 @@ tests = testGroup "Language.Haskell.Stylish.Parse" -------------------------------------------------------------------------------- testShebangExt :: Assertion -testShebangExt = assert $ isRight $ parseModule [] Nothing input - where - input = unlines - [ "#!env runghc" - , "{-# LANGUAGE CPP #-}" - , "#define foo bar \\" - , " qux" - ] +testShebangExt = returnsRight $ parseModule [] Nothing input + where + input = unlines + [ "#!env runghc" + , "{-# LANGUAGE CPP #-}" + , "#define foo bar \\" + , " qux" + ] -------------------------------------------------------------------------------- testBom :: Assertion -testBom = assert $ isRight $ parseModule [] Nothing input +testBom = returnsRight $ parseModule [] Nothing input where input = unlines [ '\xfeff' : "foo :: Int" @@ -54,13 +55,13 @@ testBom = assert $ isRight $ parseModule [] Nothing input -------------------------------------------------------------------------------- testExtraExtensions :: Assertion -testExtraExtensions = assert $ isRight $ +testExtraExtensions = returnsRight $ parseModule ["TemplateHaskell"] Nothing "$(foo)" -------------------------------------------------------------------------------- testMultilineCpp :: Assertion -testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines +testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE CPP #-}" , "#define foo bar \\" , " qux" @@ -69,7 +70,7 @@ testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testHaskell2010 :: Assertion -testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines +testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE Haskell2010 #-}" , "module X where" , "foo x | Just y <- x = y" @@ -78,7 +79,7 @@ testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testShebang :: Assertion -testShebang = assert $ isRight $ parseModule [] Nothing $ unlines +testShebang = returnsRight $ parseModule [] Nothing $ unlines [ "#!runhaskell" , "module Main where" , "main = return ()" @@ -87,7 +88,7 @@ testShebang = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testShebangDouble :: Assertion -testShebangDouble = assert $ isRight $ parseModule [] Nothing $ unlines +testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines [ "#!nix-shell" , "#!nix-shell -i runhaskell -p haskellPackages.ghc" , "module Main where" @@ -100,7 +101,7 @@ testShebangDouble = assert $ isRight $ parseModule [] Nothing $ unlines -- enabled for parsing, even when the pragma is absent. testGADTs :: Assertion -testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines +testGADTs = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data SafeList a b where" , " Nil :: SafeList a Empty" @@ -108,36 +109,35 @@ testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines ] testKindSignatures :: Assertion -testKindSignatures = assert $ isRight $ parseModule [] Nothing $ unlines +testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data D :: * -> * -> * where" , " D :: a -> b -> D a b" ] testStandaloneDeriving :: Assertion -testStandaloneDeriving = assert $ isRight $ parseModule [] Nothing $ unlines +testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "deriving instance Show MyType" ] testUnicodeSyntax :: Assertion -testUnicodeSyntax = assert $ isRight $ parseModule [] Nothing $ unlines +testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "monadic ∷ (Monad m) ⇒ m a → m a" , "monadic = id" ] testXmlSyntaxRegression :: Assertion -testXmlSyntaxRegression = assert $ isRight $ parseModule [] Nothing $ unlines +testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines [ "smaller a b = a Bool -isRight (Right _) = True -isRight _ = False +returnsRight :: HasCallStack => Show a => Either a b -> Assertion +returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index b43e6dc..4357af6 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -35,6 +35,36 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 22" case22 , testCase "case 23" case23 , testCase "case 24" case24 + , testCase "case 25" case25 + , testCase "case 26" case26 + , testCase "case 27" case27 + , testCase "case 28" case28 + , testCase "case 29" case29 + , testCase "case 30" case30 + , testCase "case 31" case31 + , testCase "case 32" case32 + , testCase "case 33" case33 + , testCase "case 34" case34 + , testCase "case 35" case35 + , testCase "case 36" case36 + , testCase "case 37" case37 + , testCase "case 38" case38 + , testCase "case 39" case39 + , testCase "case 40" case40 + , testCase "case 41" case41 + , testCase "case 42" case42 + , testCase "case 43" case43 + , testCase "case 44" case44 + , testCase "case 45" case45 + , testCase "case 46" case46 + , testCase "case 47" case47 + , testCase "case 48" case48 + , testCase "case 49" case49 + , testCase "case 50" case50 + , testCase "case 51" case51 + , testCase "case 52" case52 + , testCase "case 53" case53 + , testCase "case 54" case54 ] case00 :: Assertion @@ -165,7 +195,7 @@ case07 = expected @=? testStep (step sameSameStyle) input expected = input case08 :: Assertion -case08 = input @=? testStep (step sameSameStyle) input +case08 = expected @=? testStep (step sameSameStyle) input where input = unlines [ "module Herp where" @@ -173,6 +203,11 @@ case08 = input @=? testStep (step sameSameStyle) input , "data Phantom a =" , " Phantom" ] + expected = unlines + [ "module Herp where" + , "" + , "data Phantom a = Phantom" + ] case09 :: Assertion case09 = expected @=? testStep (step indentIndentStyle4) input @@ -333,7 +368,8 @@ case16 = expected @=? testStep (step indentIndentStyle) input , "" , "data Foo" , " = Foo" - , " { a :: Int -- ^ comment" + , " { a :: Int" + , " -- ^ comment" , " }" ] @@ -520,17 +556,661 @@ case24 = expected @=? testStep (step indentIndentStyle) input , " deriving (ToJSON)" ] +case25 :: Assertion +case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input + where + input = unlines + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + + expected = unlines + [ "data Foo a = Foo" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + +case26 :: Assertion +case26 = expected @=? testStep (step indentIndentStyle) input + where + input = unlines + [ "module Herp where" + , "" + , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo" + ] + + expected = unlines + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " }" + , " deriving (FromJSON) via Bla Foo" + ] + +case27 :: Assertion +case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + input = unlines + [ "module Herp where" + , "" + , "data Foo = Foo | Bar | Baz deriving (Eq, Show)" + ] + + expected = unlines + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " | Bar" + , " | Baz" + , " deriving (Eq, Show)" + ] + +case28 :: Assertion +case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype BankCode = BankCode {" + , " unBankCode :: Text" + , " }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype WrappedInt = WrappedInt Int" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "data MandateStatus" + , " = Approved" + , " | Failed" + , " | UserCanceled" + , " | Inactive" + , " deriving stock (Generic, Show, Eq, Enum, Bounded)" + , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype BankCode = BankCode { unBankCode :: Text }" + , " deriving stock (Eq, Generic, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" + , " deriving stock (Eq, Generic, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype WrappedInt = WrappedInt Int" + , " deriving stock (Eq, Generic, Show)" + , " deriving anyclass (Newtype)" + , "" + , "data MandateStatus" + , " = Approved" + , " | Failed" + , " | UserCanceled" + , " | Inactive" + , " deriving stock (Bounded, Enum, Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via SnakeCaseCapsEnumEncoding MandateStatus" + ] + +case29 :: Assertion +case29 = expected @=? testStep (step sameIndentStyle) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data NonEmpty a" + , " = a :| [a]" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data NonEmpty a = a :| [a]" + ] + +case30 :: Assertion +case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data ReasonCode" + , " = MissingTenantId" + , " -- Transaction errors:" + , " | TransactionDoesNotExist" + , " | TransactionAlreadyExists" + , " -- Engine errors:" + , " | EnginePersistenceError" + , " | EngineValidationError" + , " -- | Transaction was created in Info mode" + , " | RegisteredByNetworkEngine" + , " -- | Transaction was created in Routing mode" + , " | SentToNetworkEngine" + , " -- Network connection reasons:" + , " | SentToNetworkConnection" + , " | ReceivedByNetworkConnection" + , " | ValidatedByNetworkConnection" + ] + + +case31 :: Assertion +case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data ConfiguredLogger" + , " -- | Logs to file" + , " = LogTo FilePath" + , " -- | Logs to stdout" + , " | LogToConsole" + , " -- | No logging, discards all messages" + , " | NoLogging" + , " deriving stock (Generic, Show)" + ] + +case32 :: Assertion +case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data RejectionReason" + , " -- InvalidState" + , " = CancellationFailed" + , " | TotalAmountConfirmationInvalid" + , " -- InvalidApiUsage" + , " | AccessTokenNotActive" + , " | VersionNotFound" + , " -- ValidationFailed" + , " | BankAccountExists" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" + ] + +case33 :: Assertion +case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a" + , " = NonEmpty { unNonEmpty :: a }" + ] + +case34 :: Assertion +case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" + , " deriving (ToJSON, FromJSON) via Something Magic (NonEmpty a)" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a" + , " = NonEmpty { unNonEmpty :: a }" + , " deriving (FromJSON, ToJSON)" + , " via Something Magic (NonEmpty a)" + ] + +case35 :: Assertion +case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: MonetaryAmount" + , " -> TransactionId" + , " -> m (Either CreditTransferError TransactionId)" + , " }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: MonetaryAmount -> TransactionId -> m (Either CreditTransferError TransactionId)" + , " }" + ] + +case36 :: Assertion +case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: (a -> b)" + , " -> TransactionId" + , " -> m (Either CreditTransferError TransactionId)" + , " }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: (a -> b) -> TransactionId -> m (Either CreditTransferError TransactionId)" + , " }" + ] + +case37 :: Assertion +case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype UndoFlowData" + , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" + , " deriving stock (Generic, Eq, Show)" + , " deriving (ToJSON, FromJSON)" + , " via AddConstTextFields '[\"type0\" := \"undo\"," + , " \"type1\" := \"undo\"," + , " \"reversal_indicator\" := \"Undo\"] FlowDataDetails" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype UndoFlowData" + , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails" + ] + +case38 :: Assertion +case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "data Flat = Flat" + , " { foo :: Int" + , " , bar :: Text" + , " , baz :: Double" + , " , qux :: Bool" + , " }" + , " deriving stock (Generic, Show, Eq)" + , " deriving (FromJSON, ToJSON)" + , " via GenericEncoded" + , " '[ FieldLabelModifier :=" + , " '[ \"foo\" ==> \"nestFoo#foo\"" + , " , \"bar\" ==> \"nestBar#bar\"" + , " , \"baz\" ==> \"nestFoo#baz\"" + , " ]" + , " ]" + , " Flat" + ] + + expected = unlines + [ "data Flat" + , " = Flat" + , " { foo :: Int" + , " , bar :: Text" + , " , baz :: Double" + , " , qux :: Bool" + , " }" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat" + ] + +case39 :: Assertion +case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "data CreditTransfer = CreditTransfer" + , " { nestedCreditorInfo :: CreditorInfo" + , " }" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON) via" + , " ( UntaggedEncoded NordeaCreditTransfer" + , " & AddConstTextFields" + , " '[ \"request_type\" ':= \"credit_transfer\"" + , " , \"provider\" ':= \"nordea\"" + , " ]" + , " & FlattenFields '[\"nested_creditor_info\"]" + , " & RenameKeys" + , " '[ \"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\"" + , " , \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\"" + , " , \"nested_creditor_info.creditor_name\" ==> \"creditor_name\"" + , " , \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"" + , " ]" + , " )" + ] + + expected = unlines + [ "data CreditTransfer" + , " = CreditTransfer" + , " { nestedCreditorInfo :: CreditorInfo" + , " }" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" + ] + +case40 :: Assertion +case40 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input + where + input = unlines + [ "module X where" + , "" + , "data a :==> b =" + , " Arr a b" + ] + + expected = unlines + [ "module X where" + , "" + , "data a :==> b = Arr a b" + ] + +case41 :: Assertion +case41 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data Callback" + , " -- | Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , " -- incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , " -- nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , " -- Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore" + , " -- eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident," + , " -- sunt in culpa qui officia deserunt mollit anim id est laborum." + , " = KafkaTopic" + , " { callbackTopic :: CallbackTopic" + , " -- ^ Name of topic to send updates to" + , " , callbackFormat :: CallbackFormat" + , " -- ^ The format used to send these updates" + , " }" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via IdiomaticWithDescription CallbackDesc Callback" + , " deriving (HasGen) via Generically Callback" + , " deriving (FromField) via JsonField Callback" + ] + +case42 :: Assertion +case42 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data SignupError" + , " = IdempotencyConflict" + , " | ValidationError Text -- TODO: might be a sumtype of possible error codes" + , " deriving stock (Eq, Generic, Show)" + ] + +case43 :: Assertion +case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data CallbackResult" + , " -- | Callback successfully sent" + , " = Success" + , " -- | Kafka error received" + , " | KafkaIssue KafkaError" + , " deriving (Eq, Show)" + ] + +-- This test showcases a difficult to solve issue. If the comment is in a +-- deriving clause, it's very hard to guess the correct position of the entire +-- block. E.g. the deriving clause itself has the wrong position. However, if +-- we look at all deriving clauses we know where they start and end. +-- +-- This means that we've needed to make the decision to put all inline comments +-- before the deriving clause itself +case44 :: Assertion +case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = unlines + [ "module X where" + , "" + , " data CreditTransfer = CreditTransfer" + , " { amount :: Amount -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via" + , " AddConstTextFields" + , " '[\"notification_type\" ':= \"credit_transaction\"" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " ]" + , " (UntaggedEncoded CreditTransfer)" + ] + expected = unlines + [ "module X where" + , "" + , "data CreditTransfer = CreditTransfer" + , " { amount :: Amount" + , " -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" + ] + +case45 :: Assertion +case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "data CreditTransfer = CreditTransfer" + , " { amount :: Amount" + , " -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" + ] + +case46 :: Assertion +case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A format detailing which encoding to use for the settlement events" + , "data CallbackFormat" + , " -- | The Avro schema is to be used" + , " = AvroEngineEvent" + , " deriving (Bounded, Enum, Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" + , " via TypeTaggedWithDescription FormatDesc CallbackFormat" + , " deriving (HasGen)" + , " via EnumBounded CallbackFormat" + ] + +case47 :: Assertion +case47 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: (a, a) -> T [a]" + ] + +case48 :: Assertion +case48 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a, Bounded a) => (a, a) -> T [a]" + ] + +case49 :: Assertion +case49 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" + ] + +case50 :: Assertion +case50 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. Eq a => (a, a) -> T [a]" + ] + +case51 :: Assertion +case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input + where + input = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" + ] + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. Eq a => (a, a) -> T [a]" + ] + +case52 :: Assertion +case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input + where + input = unlines + [ "module X where" + , "" + , "data Foo = Foo" + , " { foo :: forall a b. (Eq a, Bounded b) => a -> b -> [(a, b)]" + , " }" + ] + expected = unlines + [ "module X where" + , "" + , "data Foo = Foo" + , " { foo :: forall a b. Eq a => Bounded b => a -> b -> [(a, b)]" + , " }" + ] + +case53 :: Assertion +case53 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input + where + input = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Functor, Applicative, Monad, MonadError, MonadCatch, Foldable, Monoid)" + ] + expected = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype" + , " ( Applicative" + , " , Foldable" + , " , Functor" + , " , Monad" + , " , MonadCatch" + , " , MonadError" + , " , Monoid" + , " )" + ] + +case54 :: Assertion +case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input + where + input = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Functor, Applicative, Monad)" + ] + expected = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Applicative, Functor, Monad)" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns diff --git a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs new file mode 100644 index 0000000..98c5d12 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs @@ -0,0 +1,382 @@ +-- | Tests contributed by Felix Mulder as part of +-- . +module Language.Haskell.Stylish.Step.Imports.FelixTests + ( tests + ) where + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Step.Imports +import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) + + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" + [ testCase "Hello world" ex0 + , testCase "Sorted simple" ex1 + , testCase "Sorted import lists" ex2 + , testCase "Sorted import lists and import decls" ex3 + , testCase "Import constructor all" ex4 + , testCase "Import constructor specific" ex5 + , testCase "Import constructor specific sorted" ex6 + , testCase "Imports step does not change rest of file" ex7 + , testCase "Imports respect groups" ex8 + , testCase "Imports respects whitespace between groups" ex9 + , testCase "Doesn't add extra space after 'hiding'" ex10 + , testCase "Should be able to format symbolic imports" ex11 + , testCase "Able to merge equivalent imports" ex12 + , testCase "Obeys max columns setting" ex13 + , testCase "Obeys max columns setting with two in each" ex14 + , testCase "Respects multiple groups" ex15 + , testCase "Doesn't delete nullary imports" ex16 + ] + +-------------------------------------------------------------------------------- +ex0 :: Assertion +ex0 = input `assertFormatted` output + where + input = + [ "import B" + , "import A" + ] + output = + [ "import A" + , "import B" + ] + +ex1 :: Assertion +ex1 = input `assertFormatted` output + where + input = + [ "import B" + , "import A" + , "import C" + , "import qualified A" + , "import qualified B as X" + ] + output = + [ "import A" + , "import qualified A" + , "import B" + , "import qualified B as X" + , "import C" + ] + +ex2 :: Assertion +ex2 = input `assertFormatted` output + where + input = + [ "import B" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + output = + [ "import A (X)" + , "import qualified A as Y (Y)" + , "import B" + , "import C" + ] + +ex3 :: Assertion +ex3 = input `assertFormatted` output + where + input = + [ "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" + ] + output = + [ "import A (X, Y, Z)" + , "import qualified A as A0 (Y, a, b)" + , "import B" + , "import C" + , "import qualified D as D0 (Y, a, b)" + , "import qualified E as E0 (Y, a, b)" + ] + +ex4 :: Assertion +ex4 = input `assertFormatted` output + where + input = + [ "import A (X, Z(..), Y)" + ] + output = + [ "import A (X, Y, Z (..))" + ] + +ex5 :: Assertion +ex5 = input `assertFormatted` output + where + input = + [ "import A (X, Z(Z), Y)" + ] + output = + [ "import A (X, Y, Z (Z))" + ] + +ex6 :: Assertion +ex6 = input `assertFormatted` output + where + input = + [ "import A (X, Z(X, Z, Y), Y)" + ] + output = + [ "import A (X, Y, Z (X, Y, Z))" + ] + +ex7 :: Assertion +ex7 = input `assertFormatted` output + where + input = + [ "module Foo (tests) where" + , "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" + , "-- hello" + , "foo :: Int" + , "foo = 1" + ] + output = + [ "module Foo (tests) where" + , "import A (X, Y, Z)" + , "import qualified A as A0 (Y, a, b)" + , "import B" + , "import C" + , "import qualified D as D0 (Y, a, b)" + , "import qualified E as E0 (Y, a, b)" + , "-- hello" + , "foo :: Int" + , "foo = 1" + ] + +ex8 :: Assertion +ex8 = input `assertFormatted` output + where + input = + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + output = + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import qualified A as Y (Y)" + , "import C" + ] + +ex9 :: Assertion +ex9 = input `assertFormatted` output + where + input = + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + output = + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import qualified A as Y (Y)" + , "import C" + ] + +ex10 :: Assertion +ex10 = input `assertFormatted` output + where + input = + [ "import B hiding (X)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import B hiding (X)" + ] + +ex11 :: Assertion +ex11 = input `assertFormatted` output + where + input = + [ "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" + ] + +ex12 :: Assertion +ex12 = input `assertFormatted` output + where + input = + [ "import Data.Aeson ((.=))" + , "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" + ] + +ex13 :: Assertion +ex13 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 10) + input = + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Foo (A)" + , "import Foo (B)" + , "import Foo (C)" + , "import Foo (D)" + ] + +ex14 :: Assertion +ex14 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 27) + input = + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Foo (A, B)" + , "import Foo (C, D)" + ] + +ex15 :: Assertion +ex15 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 100) + input = + [ "module Custom.Prelude" + , " ( LazyByteString" + , " , UUID" + , " , decodeUtf8Lenient" + , " , error" + , " , headMay" + , " , module X" + , " , nextRandomUUID" + , " , onChars" + , " , proxyOf" + , " , show" + , " , showStr" + , " , toLazyByteString" + , " , toStrictByteString" + , " , type (~>)" + , " , uuidToText" + , " ) where" + , "" + , "--------------------------------------------------------------------------------" + , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" + , "import qualified Prelude" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans, set, to, view)" + , "import Control.Lens.Extras as X (is)" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "--------------------------------------------------------------------------------" + ] + output = + [ "module Custom.Prelude" + , " ( LazyByteString" + , " , UUID" + , " , decodeUtf8Lenient" + , " , error" + , " , headMay" + , " , module X" + , " , nextRandomUUID" + , " , onChars" + , " , proxyOf" + , " , show" + , " , showStr" + , " , toLazyByteString" + , " , toStrictByteString" + , " , type (~>)" + , " , uuidToText" + , " ) where" + , "" + , "--------------------------------------------------------------------------------" + , "import Prelude as X hiding (appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile, (!!))" + , "import qualified Prelude" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X (_Left, _Right, iat, over, preview, sans, set, to)" + , "import Control.Lens as X (view, (%~), (&), (.~), (?~), (^.), (^?))" + , "import Control.Lens.Extras as X (is)" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X (guard, unless, when, (<=<), (>=>))" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither)" + , "import Control.Monad.Except as X (runExceptT, withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "--------------------------------------------------------------------------------" + ] + +ex16 :: Assertion +ex16 = input `assertFormatted` output + where + input = + [ "module Foo where" + , "" + , "import B ()" + , "import A ()" + ] + output = + [ "module Foo where" + , "" + , "import A ()" + , "import B ()" + ] + +assertFormatted :: HasCallStack => Lines -> Lines -> Assertion +assertFormatted = withFrozenCallStack $ assertFormatted' Nothing + +assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion +assertFormatted' maxColumns input expected = + withFrozenCallStack $ expected @=?? testStep' (step maxColumns felixOptions) input + where + felixOptions = defaultOptions + { listAlign = Repeat + } diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 22031d4..474de66 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -5,9 +5,9 @@ module Language.Haskell.Stylish.Step.Imports.Tests -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- @@ -15,7 +15,6 @@ import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util - -------------------------------------------------------------------------------- fromImportAlign :: ImportAlign -> Options fromImportAlign align = defaultOptions { importAlign = align } @@ -63,8 +62,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" -------------------------------------------------------------------------------- -input :: String -input = unlines +input :: Snippet +input = Snippet [ "module Herp where" , "" , "import qualified Data.Map as M" @@ -83,9 +82,9 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input +case01 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -105,9 +104,9 @@ case01 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) $ fromImportAlign Group) input +case02 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Group) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -126,9 +125,9 @@ case02 = expected @=? testStep (step (Just 80) $ fromImportAlign Group) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) $ fromImportAlign None) input +case03 = expected @=? testSnippet (step (Just 80) $ fromImportAlign None) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -147,13 +146,13 @@ case03 = expected @=? testStep (step (Just 80) $ fromImportAlign None) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input' +case04 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input' where - input' = + input' = Snippet $ pure $ "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" - expected = unlines + expected = Snippet [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," , " object, parseEither, typeMismatch, (.!=)," , " (.:), (.:?), (.=))" @@ -162,17 +161,18 @@ case04 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input' -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep (step (Just 80) $ fromImportAlign Group) input' +case05 = input' @=? testSnippet (step (Just 80) $ fromImportAlign Group) input' where - input' = "import Distribution.PackageDescription.Configuration " ++ - "(finalizePackageDescription)\n" + -- Putting this on a different line shouldn't really help. + input' = Snippet ["import Distribution.PackageDescription.Configuration " ++ + "(finalizePackageDescription)"] -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input' +case06 = input' @=? testStep' (step (Just 80) $ fromImportAlign File) input' where - input' = unlines + input' = [ "import Bar.Qux" , "import Foo.Bar" ] @@ -180,15 +180,16 @@ case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input' +case07 = + expected @=? testSnippet (step (Just 80) $ fromImportAlign File) input' where - input' = unlines + input' = Snippet [ "import Bar.Qux" , "" , "import qualified Foo.Bar" ] - expected = unlines + expected = Snippet [ "import Bar.Qux" , "" , "import qualified Foo.Bar" @@ -197,10 +198,13 @@ case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Inline Inherit (LPConstant 4) True False) input +case08 = + let + options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -220,10 +224,13 @@ case08 = expected -------------------------------------------------------------------------------- case08b :: Assertion -case08b = expected - @=? testStep (step (Just 80) $ Options Global WithModuleName True Inline Inherit (LPConstant 4) True False) input +case08b = + let + options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input where - expected = unlines + expected = Snippet ["module Herp where" , "" , "import Control.Monad" @@ -242,10 +249,13 @@ case08b = expected -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Multiline Inherit (LPConstant 4) True False) input +case09 = + let + options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -276,10 +286,13 @@ case09 = expected -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected - @=? testStep (step (Just 40) $ Options Group WithAlias True Multiline Inherit (LPConstant 4) True False) input +case10 = + let + options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 40) options) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -313,12 +326,16 @@ case10 = expected ] + -------------------------------------------------------------------------------- case11 :: Assertion -case11 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 4) True False) input +case11 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -342,10 +359,13 @@ case11 = expected case11b :: Assertion -case11b = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 4) True False) input +case11b = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -364,14 +384,17 @@ case11b = expected -------------------------------------------------------------------------------- case12 :: Assertion -case12 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 2) True False) input' +case12 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 2) True False + in + expected @=? testSnippet (step (Just 80) options) input' where - input' = unlines + input' = Snippet [ "import Data.List (map)" ] - expected = unlines + expected = Snippet [ "import Data.List" , " (map)" ] @@ -379,27 +402,31 @@ case12 = expected -------------------------------------------------------------------------------- case12b :: Assertion -case12b = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 2) True False) input' +case12b = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False + in + expected @=? testStep' (step (Just 80) options) input' where - input' = unlines - [ "import Data.List (map)" - ] + input' = ["import Data.List (map)"] expected = input' -------------------------------------------------------------------------------- case13 :: Assertion -case13 = expected - @=? testStep (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False) input' +case13 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input' where - input' = unlines + input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] - expected = unlines + expected = Snippet [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" @@ -408,15 +435,18 @@ case13 = expected -------------------------------------------------------------------------------- case13b :: Assertion -case13b = expected - @=? testStep (step (Just 80) $ Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False) input' +case13b = + let + options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input' where - input' = unlines + input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] - expected = unlines + expected = Snippet [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" @@ -425,21 +455,26 @@ case13b = expected -------------------------------------------------------------------------------- case14 :: Assertion -case14 = expected - @=? testStep - (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False) expected +case14 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False + in + expected @=? testSnippet (step (Just 80) options) expected where - expected = unlines + expected = Snippet [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" ] -------------------------------------------------------------------------------- case15 :: Assertion -case15 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' +case15 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid" , " ( closeAcidState" @@ -451,7 +486,7 @@ case15 = expected , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" , "import Data.Default.Class (Default (def))" @@ -462,10 +497,13 @@ case15 = expected -------------------------------------------------------------------------------- case16 :: Assertion -case16 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) False False) input' +case16 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False + in + expected @=? testSnippet (step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -474,7 +512,7 @@ case16 = expected , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -486,16 +524,19 @@ case16 = expected -------------------------------------------------------------------------------- case17 :: Assertion -case17 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' +case17 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Control.Applicative (Applicative (pure, (<*>)))" , "" , "import Data.Identity (Identity (Identity, runIdentity))" ] - input' = unlines + input' = Snippet [ "import Control.Applicative (Applicative ((<*>),pure))" , "" , "import Data.Identity (Identity (runIdentity,Identity))" @@ -504,10 +545,13 @@ case17 = expected -------------------------------------------------------------------------------- case18 :: Assertion -case18 = expected @=? testStep - (step (Just 40) $ Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False) input' +case18 = + let + options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False + in + expected @=? testSnippet (step (Just 40) options) input' where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" @@ -521,7 +565,7 @@ case18 = expected @=? testStep , " )" ] - input' = unlines + input' = Snippet [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" , "import Data.Identity (Identity (Identity, runIdentity))" @@ -532,10 +576,13 @@ case18 = expected @=? testStep -------------------------------------------------------------------------------- case19 :: Assertion -case19 = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input +case19 = + let + options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False + in + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -548,14 +595,16 @@ case19 = expected @=? testStep case19b :: Assertion -case19b = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input +case19b = + let + options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False + in + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" + , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," @@ -564,14 +613,16 @@ case19b = expected @=? testStep case19c :: Assertion -case19c = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input +case19c = + let + options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False + in + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" + , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," @@ -580,10 +631,13 @@ case19c = expected @=? testStep case19d :: Assertion -case19d = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input +case19d = + let + options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False + in + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -595,27 +649,27 @@ case19d = expected @=? testStep ] -case19input :: String -case19input = unlines - [ "import Prelude.Compat hiding (foldMap)" - , "import Prelude ()" - , "" - , "import Data.List (foldl', intercalate, intersperse)" - ] +case19input :: Snippet +case19input = Snippet + [ "import Prelude.Compat hiding (foldMap)" + , "import Prelude ()" + , "" + , "import Data.List (foldl', intercalate, intersperse)" + ] -------------------------------------------------------------------------------- case20 :: Assertion case20 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where - expected = unlines - [ "import {-# SOURCE #-} Data.ByteString as BS" - , "import qualified Data.Map as Map" - , "import Data.Set (empty)" + expected = Snippet + [ "import {-# SOURCE #-} Data.ByteString as BS" + , "import qualified Data.Map as Map" + , "import Data.Set (empty)" , "import {-# SOURCE #-} qualified Data.Text as T" ] - input' = unlines + input' = Snippet [ "import {-# SOURCE #-} Data.ByteString as BS" , "import {-# SOURCE #-} qualified Data.Text as T" , "import qualified Data.Map as Map" @@ -626,9 +680,9 @@ case20 = expected -------------------------------------------------------------------------------- case21 :: Assertion case21 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where - expected = unlines + expected = Snippet [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, C)" , "import X2 (A, B, C)" @@ -640,7 +694,7 @@ case21 = expected , "import X8 (type (+), (+))" , "import X9 hiding (x, y, z)" ] - input' = unlines + input' = Snippet [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, A, C, A, B, A)" , "import X2 (C(), B(), A())" @@ -657,9 +711,9 @@ case21 = expected -------------------------------------------------------------------------------- case22 :: Assertion case22 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where - expected = unlines + expected = Snippet [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"blah\" A" @@ -668,7 +722,7 @@ case22 = expected , "import \"foo\" B (shortName, someLongName, someLongerName," , " theLongestNameYet)" ] - input' = unlines + input' = Snippet [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"foo\" A" @@ -683,10 +737,14 @@ case22 = expected -------------------------------------------------------------------------------- case23 :: Assertion -case23 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False Inline Inherit (LPConstant 4) True True) input' +case23 = + let + options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True + in + expected @=? testSnippet (step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class ( Default (def) )" , "" @@ -696,7 +754,7 @@ case23 = expected , " Goo )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -708,10 +766,14 @@ case23 = expected -------------------------------------------------------------------------------- case23b :: Assertion -case23b = expected - @=? testStep (step (Just 40) $ Options None WithModuleName False Inline Inherit (LPConstant 4) True True) input' +case23b = + let + options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True + in + expected @=? testSnippet (step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" @@ -722,7 +784,7 @@ case23b = expected , " Goo )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -734,10 +796,14 @@ case23b = expected -------------------------------------------------------------------------------- case24 :: Assertion -case24 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True) input' +case24 = + let + options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True + in + expected @=? testSnippet (step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" @@ -747,7 +813,7 @@ case24 = expected , " GooReallyLong )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -758,10 +824,13 @@ case24 = expected -------------------------------------------------------------------------------- case25 :: Assertion -case25 = expected - @=? testStep (step (Just 80) $ Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False) input' +case25 = + let + options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False + in + expected @=? testSnippet (step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -770,7 +839,7 @@ case25 = expected , "" , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -784,22 +853,18 @@ case25 = expected -------------------------------------------------------------------------------- case26 :: Assertion case26 = expected - @=? testStep (step (Just 80) options ) input' + @=? testSnippet (step (Just 80) options ) input' where options = defaultOptions { listAlign = NewLine, longListAlign = Multiline } - input' = unlines - [ "import Data.List" - ] - expected = unlines - [ "import Data.List" - ] + input' = Snippet ["import Data.List"] + expected = Snippet ["import Data.List"] -------------------------------------------------------------------------------- case27 :: Assertion -case27 = expected @=? testStep (step Nothing $ fromImportAlign Global) input +case27 = expected @=? testSnippet (step Nothing $ fromImportAlign Global) input where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 0ede803..0c19c02 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.LanguagePragmas.Tests ( tests ) where @@ -7,7 +8,7 @@ module Language.Haskell.Stylish.Step.LanguagePragmas.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -30,6 +31,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 + , testCase "case 13" case13 ] lANG :: String @@ -37,202 +39,191 @@ lANG = "LANGUAGE" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) Vertical True False lANG) input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" - , "module Main where" - ] +case01 = assertSnippet + (step (Just 80) Vertical True False lANG) + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "module Main where" + ] - expected = unlines - [ "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "module Main where" - ] + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) Vertical True True lANG) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] +case02 = assertSnippet + (step (Just 80) Vertical True True lANG) + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] - expected = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] + [ "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) Vertical True True lANG) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] +case03 = assertSnippet + (step (Just 80) Vertical True True lANG) + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] - expected = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] + [ "{-# LANGUAGE BangPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] +case04 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell," - , " TypeOperators, ViewPatterns #-}" - ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell," + , " TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep (step (Just 80) Vertical True False lANG) input - where - input = unlines - [ "{-# LANGUAGE CPP #-}" - , "" - , "#if __GLASGOW_HASKELL__ >= 702" - , "{-# LANGUAGE Trustworthy #-}" - , "#endif" - ] +case05 = assertSnippet + (step (Just 80) Vertical True False lANG) + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] - expected = unlines - [ "{-# LANGUAGE CPP #-}" - , "" - , "#if __GLASGOW_HASKELL__ >= 702" - , "{-# LANGUAGE Trustworthy #-}" - , "#endif" - ] + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] -------------------------------------------------------------------------------- case06 :: Assertion -case06 = expected @=? testStep (step (Just 80) CompactLine True False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell #-}" - , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" - ] +case06 = assertSnippet + (step (Just 80) CompactLine True False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step (Just 80) Vertical False False lANG) input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] +case07 = assertSnippet + (step (Just 80) Vertical False False lANG) + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] - expected = unlines - [ "{-# LANGUAGE NoImplicitPrelude #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "module Main where" - ] + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testStep (step (Just 80) CompactLine False False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell #-}" - , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" - ] +case08 = assertSnippet + (step (Just 80) CompactLine False False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ - "TypeApplications" - , " #-}" - ] - expected = unlines - [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," - , " TypeApplications #-}" - ] +case09 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ + "TypeApplications" + , " #-}" + ] + [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," + , " TypeApplications #-}" + ] -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," - , " TypeApplications #-}" - ] - expected = unlines - [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ - "TypeApplications #-}" - ] +case10 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," + , " TypeApplications #-}" + ] + [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ + "TypeApplications #-}" + ] -------------------------------------------------------------------------------- case11 :: Assertion -case11 = expected @=? testStep (step (Just 80) Vertical False False "language") input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] +case11 = assertSnippet + (step (Just 80) Vertical False False "language") + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + [ "{-# language NoImplicitPrelude #-}" + , "{-# language ScopedTypeVariables #-}" + , "{-# language TemplateHaskell #-}" + , "{-# language ViewPatterns #-}" + , "module Main where" + ] - expected = unlines - [ "{-# language NoImplicitPrelude #-}" - , "{-# language ScopedTypeVariables #-}" - , "{-# language TemplateHaskell #-}" - , "{-# language ViewPatterns #-}" - , "module Main where" - ] -------------------------------------------------------------------------------- case12 :: Assertion -case12 = expected @=? testStep (step Nothing Compact False False "language") input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] +case12 = assertSnippet + (step Nothing Compact False False "language") + [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" + , "module Main where" + ] + - expected = unlines - [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" - , "module Main where" +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = assertSnippet + (step Nothing Vertical True True lANG) input input + where + input = + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE DeriveFunctor #-}" + , "main = let !x = 1 + 1 in print x" ] diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs new file mode 100644 index 0000000..b6d6b89 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedLists #-} +module Language.Haskell.Stylish.Step.ModuleHeader.Tests + ( tests + ) where + +-------------------------------------------------------------------------------- +import Prelude hiding (lines) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.ModuleHeader +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" + [ testCase "Hello world" ex0 + , testCase "Empty exports list" ex1 + , testCase "Single exported variable" ex2 + , testCase "Multiple exported variables" ex3 + , testCase "Only reformats module header" ex4 + , testCase "Leaving pragmas in place" ex5 + , testCase "Leaving pragmas in place variant" ex6 + , testCase "Leaving comments in place" ex7 + , testCase "Exports all" ex8 + , testCase "Exports module" ex9 + , testCase "Exports symbol" ex10 + , testCase "Respects groups" ex11 + , testCase "'where' not repeated in case it isn't part of exports" ex12 + , testCase "Indents absent export list with 2 spaces" ex13 + , testCase "Indents with 2 spaces" ex14 + , testCase "Group doc with 2 spaces" ex15 + , testCase "Does not sort" ex16 + ] + +-------------------------------------------------------------------------------- +ex0 :: Assertion +ex0 = assertSnippet (step defaultConfig) + [ "module Foo where" + ] + [ "module Foo" + , " where" + ] + +ex1 :: Assertion +ex1 = assertSnippet (step defaultConfig) + [ "module Foo () where" + ] + [ "module Foo" + , " (" + , " ) where" + ] + +ex2 :: Assertion +ex2 = assertSnippet (step defaultConfig) + [ "module Foo (tests) where" + ] + [ "module Foo" + , " ( tests" + , " ) where" + ] + +ex3 :: Assertion +ex3 = assertSnippet (step defaultConfig) + [ "module Foo (t1, t2, t3) where" + ] + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + +ex4 :: Assertion +ex4 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] + +ex5 :: Assertion +ex5 = assertSnippet (step defaultConfig) + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + +ex6 :: Assertion +ex6 = assertSnippet (step defaultConfig) + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + +ex7 :: Assertion +ex7 = assertSnippet (step defaultConfig) + [ "module Foo -- Foo" + , "(" + , " -- * t1 something" + , " t3," + , " t1," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + [ "module Foo -- Foo" + , " ( -- * t1 something" + , " t1" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where -- x" + , "-- y" + ] + + +ex8 :: Assertion +ex8 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- * t1 something" + , " t3," + , " A(..)," + , " -- * t2 something" + , " t2," + , " t1" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( -- * t1 something" + , " A (..)" + , " , t3" + , " -- * t2 something" + , " , t1" + , " , t2" + , " ) where -- x" + , "-- y" + ] + +ex9 :: Assertion +ex9 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- * t1 something" + , " module A," + , " t3," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( -- * t1 something" + , " module A" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where -- x" + , "-- y" + ] + +ex10 :: Assertion +ex10 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " (<&>)" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( (<&>)" + , " ) where -- x" + , "-- y" + ] + +ex11 :: Assertion +ex11 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- group 1" + , " g1_1," + , " g1_0," + , " -- group 2" + , " g0_1," + , " g0_0" + , ") where" + ] + [ "module Foo" + , " ( -- group 1" + , " g1_0" + , " , g1_1" + , " -- group 2" + , " , g0_0" + , " , g0_1" + , " ) where" + ] + +ex12 :: Assertion +ex12 = assertSnippet (step defaultConfig) + [ "module Foo" + , " where" + , "-- hmm" + ] + [ "module Foo" + , " where" + , "-- hmm" + ] + +ex13 :: Assertion +ex13 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo where" + ] + [ "module Foo" + , " where" + ] + +ex14 :: Assertion +ex14 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo" + , " ( yes" + , " , no" + , " ) where" + ] + [ "module Foo" + , " ( no" + , " , yes" + , " ) where" + ] + +ex15 :: Assertion +ex15 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo -- Foo" + , "(" + , " -- * t1 something" + , " t3," + , " t1," + , " -- * t2 something" + , " t2" + , ") where" + ] + [ "module Foo -- Foo" + , " ( -- * t1 something" + , " t1" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where" + ] + +ex16 :: Assertion +ex16 = assertSnippet (step defaultConfig {sort = False}) input input + where + input = + [ "module Foo" + , " ( yes" + , " , no" + , " ) where" + ] diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index a2a51fc..fa17784 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.SimpleAlign.Tests ( tests ) where @@ -7,7 +8,7 @@ module Language.Haskell.Stylish.Step.SimpleAlign.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -27,81 +28,68 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 07" case07 , testCase "case 08" case08 , testCase "case 09" case09 + , testCase "case 10" case10 + , testCase "case 11" case11 + , testCase "case 12" case12 ] -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) defaultConfig) input - where - input = unlines - [ "eitherToMaybe e = case e of" - , " Left _ -> Nothing" - , " Right x -> Just x" - ] - - expected = unlines - [ "eitherToMaybe e = case e of" - , " Left _ -> Nothing" - , " Right x -> Just x" - ] +case01 = assertSnippet (step (Just 80) defaultConfig) + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) defaultConfig) input - where - input = unlines - [ "eitherToMaybe (Left _) = Nothing" - , "eitherToMaybe (Right x) = Just x" - ] - - expected = unlines - [ "eitherToMaybe (Left _) = Nothing" - , "eitherToMaybe (Right x) = Just x" - ] +case02 = assertSnippet (step (Just 80) defaultConfig) + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) defaultConfig) input - where - input = unlines - [ "heady def [] = def" - , "heady _ (x : _) = x" - ] - - expected = unlines - [ "heady def [] = def" - , "heady _ (x : _) = x" - ] +case03 = assertSnippet (step (Just 80) defaultConfig) + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) defaultConfig) input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] +case04 = assertSnippet (step (Just 80) defaultConfig) + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input @=? testStep (step (Just 80) defaultConfig) input +case05 = assertSnippet (step (Just 80) defaultConfig) input input where -- Don't attempt to align this since a field spans multiple lines - input = unlines + input = [ "data Foo = Foo" , " { foo :: Int" , " , barqux" @@ -112,78 +100,102 @@ case05 = input @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case06 :: Assertion -case06 = +case06 = assertSnippet -- 22 max columns is /just/ enough to align this stuff. - expected @=? testStep (step (Just 22) defaultConfig) input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] + (step (Just 22) defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] -------------------------------------------------------------------------------- case07 :: Assertion -case07 = +case07 = assertSnippet -- 21 max columns is /just NOT/ enough to align this stuff. - expected @=? testStep (step (Just 21) defaultConfig) input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] + (step (Just 21) defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testStep (step (Just 80) defaultConfig) input - where - input = unlines - [ "canDrink mbAge = case mbAge of" - , " Just age | age > 18 -> True" - , " _ -> False" - ] - - expected = unlines - [ "canDrink mbAge = case mbAge of" - , " Just age | age > 18 -> True" - , " _ -> False" - ] +case08 = assertSnippet (step (Just 80) defaultConfig) + [ "canDrink mbAge = case mbAge of" + , " Just age | age > 18 -> True" + , " _ -> False" + ] + [ "canDrink mbAge = case mbAge of" + , " Just age | age > 18 -> True" + , " _ -> False" + ] -------------------------------------------------------------------------------- case09 :: Assertion -case09 = - expected @=? testStep (step Nothing defaultConfig) input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] +case09 = assertSnippet (step Nothing defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] - expected = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" + +-------------------------------------------------------------------------------- +case10 :: Assertion +case10 = assertSnippet (step Nothing defaultConfig) + [ "padQual = case align' of" + , " Global -> True" + , " File -> fileAlign" + , " Group -> anyQual" + ] + [ "padQual = case align' of" + , " Global -> True" + , " File -> fileAlign" + , " Group -> anyQual" + ] + + +-------------------------------------------------------------------------------- +case11 :: Assertion +case11 = assertSnippet (step Nothing defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: !Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: !Int" + , " }" + ] + + +-------------------------------------------------------------------------------- +case12 :: Assertion +case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input + where + input = + [ "case x of" + , " Just y -> 1" + , " Nothing -> 2" ] diff --git a/tests/Language/Haskell/Stylish/Tests.hs b/tests/Language/Haskell/Stylish/Tests.hs index 97eab8a..b99e620 100644 --- a/tests/Language/Haskell/Stylish/Tests.hs +++ b/tests/Language/Haskell/Stylish/Tests.hs @@ -49,6 +49,7 @@ case02 = withTestDirTree $ do , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 2" + , " via: \"indent 2\"" ] actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input @@ -73,6 +74,7 @@ case03 = withTestDirTree $ do , " first_field: \"same_line\"" , " field_comment: 2" , " deriving: 2" + , " via: \"indent 2\"" ] actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input @@ -98,10 +100,8 @@ case04 = (@?= result) =<< format Nothing (Just fileLocation) input fileLocation = "directory/File.hs" input = "module Herp" result = Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " <> - fileLocation <> - ": ParseFailed (SrcLoc \".hs\" 2 1) \"Parse error: EOF\"" - + fileLocation <> ": RealSrcSpan SrcSpanPoint \"directory/File.hs\" 2 1:" + <> " parse error (possibly incorrect indentation or mismatched brackets)\n" -------------------------------------------------------------------------------- -- | When providing current dir including folders and files. diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index f43b6b5..b3d200f 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -1,11 +1,21 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Tests.Util ( testStep + , testStep' + , Snippet (..) + , testSnippet + , assertSnippet , withTestDirTree + , (@=??) ) where -------------------------------------------------------------------------------- import Control.Exception (bracket, try) +import Control.Monad.Writer (execWriter, tell) +import Data.List (intercalate) +import GHC.Exts (IsList (..)) import System.Directory (createDirectory, getCurrentDirectory, getTemporaryDirectory, @@ -14,6 +24,8 @@ import System.Directory (createDirectory, import System.FilePath (()) import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) +import Test.HUnit (Assertion, assertFailure, + (@=?)) -------------------------------------------------------------------------------- @@ -23,13 +35,44 @@ import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- testStep :: Step -> String -> String -testStep step str = case parseModule [] Nothing str of - Left err -> error err - Right module' -> unlines $ stepFilter step ls module' +testStep s str = case s of + Step _ step -> + case parseModule [] Nothing str of + Left err -> error err + Right module' -> unlines $ step ls module' where ls = lines str +-------------------------------------------------------------------------------- +testStep' :: Step -> Lines -> Lines +testStep' s ls = lines $ testStep s (unlines ls) + + +-------------------------------------------------------------------------------- +-- | 'Lines' that show as a normal string. +newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) + +-- Prefix with one newline since so HUnit will use a newline after `got: ` or +-- `expected: `. +instance Show Snippet where show = unlines . ("" :) . unSnippet + +instance IsList Snippet where + type Item Snippet = String + fromList = Snippet + toList = unSnippet + + +-------------------------------------------------------------------------------- +testSnippet :: Step -> Snippet -> Snippet +testSnippet s = Snippet . lines . testStep s . unlines . unSnippet + + +-------------------------------------------------------------------------------- +assertSnippet :: Step -> Snippet -> Snippet -> Assertion +assertSnippet step input expected = expected @=? testSnippet step input + + -------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template -- provided @@ -59,3 +102,15 @@ withTestDirTree action = bracket setCurrentDirectory current *> removeDirectoryRecursive temp) (\(_, temp) -> setCurrentDirectory temp *> action) + +(@=??) :: Lines -> Lines -> Assertion +expected @=?? actual = + if expected == actual then pure () + else assertFailure $ intercalate "\n" $ execWriter do + tell ["Expected:"] + printLines expected + tell ["Got:"] + printLines actual + where + printLines = + mapM_ \line -> tell [" " <> line] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index d2023ed..501821b 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -13,6 +13,8 @@ import qualified Language.Haskell.Stylish.Config.Tests import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Data.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests +import qualified Language.Haskell.Stylish.Step.Imports.FelixTests +import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests import qualified Language.Haskell.Stylish.Step.Squash.Tests @@ -29,7 +31,9 @@ main = defaultMain , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests + , Language.Haskell.Stylish.Step.Imports.FelixTests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests + , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests , Language.Haskell.Stylish.Step.Squash.Tests.tests , Language.Haskell.Stylish.Step.Tabs.Tests.tests -- cgit v1.2.3 From a5bc07f7121244880e161153fea8d546788202a2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 2 Oct 2020 13:27:37 +0200 Subject: Bump version to 0.12.0.0 --- CHANGELOG | 33 +++++++++++++++++++++++++++++++++ stylish-haskell.cabal | 2 +- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 56faa64..2981385 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,38 @@ # CHANGELOG +- 0.12.0.0 (2020-10-02) + * Use ghc-lib-parser rather than haskell-src-exts + + This patch swaps out the parsing library from `haskell-src-exts` to + `ghc-lib-parser`, which gives us better compatibility with GHC. + + Because almost every module heavily used the Haskell AST provided by + `haskell-src-exts`, this was a huge effort and it would not have been + possible without Felix Mulder doing an initial port, GSoC student + Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and + Paweł Szulc who helped me finish up things in the home stretch. + + I've generally tried to keep styling 100% compatible with what was there + before, but some issues may have unintentionally slipped in so please + report those. + + This introduces one new import styling contributed by Felix: when + wrapping import lists over multiple lines, you can repeat the module + name, e.g.: + + import Control.Monad.Except as X (ExceptT (..), MonadError (..)) + import Control.Monad.Except as X (runExceptT, withExceptT) + + This is activated by using `import_align: repeat`. + + Secondly, a new Step was added, `module_header`, which formats the + export list of a module, including the trailing `where` clause. Details + for this new step can be found in the `data/stylish-haskell.yaml`. + + * Remove `semigroup` dependency for GHC >= 8.0 + * Bump `strict` upper bound to 0.4 + * Bump `Cabal` upper bound to 3.3 for test suite + - 0.11.0.3 (2020-08-02) * Set default-language to Haskell2010 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index cb1f6a1..ebce872 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.11.0.3 +Version: 0.12.0.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 -- cgit v1.2.3 From 2cc5f101fd7d070918939826243d908565eb2ee9 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 2 Oct 2020 14:07:38 +0200 Subject: Bump README.markdown --- README.markdown | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/README.markdown b/README.markdown index e420417..199b95d 100644 --- a/README.markdown +++ b/README.markdown @@ -2,7 +2,7 @@ -[![Build Status](https://img.shields.io/circleci/project/github/jaspervdj/stylish-haskell.svg)](https://circleci.com/gh/jaspervdj/stylish-haskell) +![Build Status](https://github.com/jaspervdj/patat/workflows/CI/badge.svg) ## Introduction @@ -235,3 +235,7 @@ Contributors: - Leonid Onokhov - Michael Snoyman - Mikhail Glushenkov +- Beatrice Vergani +- Paweł Szulc +- Łukasz Gołębiewski +- Felix Mulder -- cgit v1.2.3 From 20dbe3a444a79dc5a8e0bf564b987db5393d127b Mon Sep 17 00:00:00 2001 From: Jonatan Borkowski Date: Mon, 5 Oct 2020 00:42:02 +0200 Subject: Add a test to cover Imports duplicate removal Fixes #184 --- .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 33 ++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 474de66..bb56bab 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -58,6 +58,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" , testCase "case 25" case25 , testCase "case 26 (issue 185)" case26 , testCase "case 27" case27 + , testCase "case 28" case28 ] @@ -878,3 +879,35 @@ case27 = expected @=? testSnippet (step Nothing $ fromImportAlign Global) input , "" , "herp = putStrLn \"import Hello world\"" ] + + +-------------------------------------------------------------------------------- +case28 :: Assertion +case28 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input' + where + expected = Snippet + [ "import Control.Monad" + , "import qualified Data.Aeson as JSON" + , "import Data.Default.Class (Default (def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe (Just, Nothing))" + , "" + , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" + , "import Data.Set (empty, intersect, nub)" + ] + input' = Snippet + [ "import Data.Default.Class (Default(def))" + , "import qualified Data.Aeson as JSON" + , "import qualified Data.Aeson as JSON" + , "import Control.Monad" + , "import Control.Monad" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + , "import Data.Foo (Foo (Foo,Bar))" + , "import Data.Set (empty, intersect)" + , "import Data.Set (empty, nub)" + ] -- cgit v1.2.3 From 3f4edcce319c3dafd1d1309b281625beb854e8a7 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 5 Oct 2020 01:53:26 +0300 Subject: Fix "group" import sort with multi-line imports When some import line spans multuple lines, e.g. when import list is long, stylish-haskell breaks a group at this line, leading to bad result. This commits makes sure that import groups are recognized solely by empty lines. --- lib/Language/Haskell/Stylish/Module.hs | 9 ++++++--- .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 23 ++++++++++++++++++++++ 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 3647f3c..2cc8f47 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -201,10 +201,13 @@ moduleImportGroups = go [] Nothing . moduleImports -> [NonEmpty (Located Import)] go acc _ [] = ne acc go acc mbCurrentLine (imp : impRest) = - let l2 = getStartLineUnsafe imp in + let + lStart = getStartLineUnsafe imp + lEnd = getEndLineUnsafe imp in case mbCurrentLine of - Just l1 | l1 + 1 < l2 -> ne acc ++ go [imp] (Just l2) impRest - _ -> go (acc ++ [imp]) (Just l2) impRest + Just lPrevEnd | lPrevEnd + 1 < lStart + -> ne acc ++ go [imp] (Just lEnd) impRest + _ -> go (acc ++ [imp]) (Just lEnd) impRest ne [] = [] ne (x : xs) = [x :| xs] diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index bb56bab..fea3b78 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -59,6 +59,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" , testCase "case 26 (issue 185)" case26 , testCase "case 27" case27 , testCase "case 28" case28 + , testCase "case 29" case29 ] @@ -911,3 +912,25 @@ case28 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) inpu , "import Data.Set (empty, intersect)" , "import Data.Set (empty, nub)" ] + + +-------------------------------------------------------------------------------- +case29 :: Assertion +case29 = expected @=? testSnippet (step Nothing $ fromImportAlign Group) input' + where + -- Check that "Group" mode recognizes groups with multi-line imports + input' = Snippet + [ "import Foo (foo)" + , "import BarBar ( bar" + , " , kek)" + , "import Abcd ()" + , "" + , "import A (A)" + ] + expected = Snippet + [ "import Abcd ()" + , "import BarBar (bar, kek)" + , "import Foo (foo)" + , "" + , "import A (A)" + ] \ No newline at end of file -- cgit v1.2.3 From be4c965afe599a1f5bb8392a47985eb828b4a866 Mon Sep 17 00:00:00 2001 From: Łukasz Gołębiewski Date: Mon, 5 Oct 2020 09:21:40 +0200 Subject: Fix typo (#314) --- lib/Language/Haskell/Stylish/Util.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 90bea63..1d35a03 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -22,8 +22,8 @@ module Language.Haskell.Stylish.Util , toRealSrcSpan - , traceOutputtable - , traceOutputtableM + , traceOutputable + , traceOutputableM , unguardedRhsBody , rhsBody @@ -213,14 +213,14 @@ flagEnds = \case -------------------------------------------------------------------------------- -traceOutputtable :: Outputable.Outputable a => String -> a -> b -> b -traceOutputtable title x = +traceOutputable :: Outputable.Outputable a => String -> a -> b -> b +traceOutputable title x = trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x)) -------------------------------------------------------------------------------- -traceOutputtableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () -traceOutputtableM title x = traceOutputtable title x $ pure () +traceOutputableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () +traceOutputableM title x = traceOutputable title x $ pure () -------------------------------------------------------------------------------- -- cgit v1.2.3 From 3a80aea0dc040d41a5e985732a265d7b9e8d0b74 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 5 Oct 2020 12:07:08 +0200 Subject: Clean up/unify import tests --- .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 1076 +++++++++----------- 1 file changed, 488 insertions(+), 588 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index fea3b78..6521a8e 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Imports.Tests ( tests ) where @@ -65,7 +66,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" -------------------------------------------------------------------------------- input :: Snippet -input = Snippet +input = [ "module Herp where" , "" , "import qualified Data.Map as M" @@ -84,95 +85,86 @@ input = Snippet -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse," - , " tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] +case01 = assertSnippet (step (Just 80) $ fromImportAlign Global) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse," + , " tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Group) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init, last," - , " length, map, null, reverse, tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] +case02 = assertSnippet (step (Just 80) $ fromImportAlign Group) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last," + , " length, map, null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testSnippet (step (Just 80) $ fromImportAlign None) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map," - , " null, reverse, tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] +case03 = assertSnippet (step (Just 80) $ fromImportAlign None) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map," + , " null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input' - where - input' = Snippet $ pure $ - "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ +case04 = assertSnippet (step (Just 80) $ fromImportAlign Global) + [ "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" - - expected = Snippet - [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," - , " object, parseEither, typeMismatch, (.!=)," - , " (.:), (.:?), (.=))" - ] + ] + [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," + , " object, parseEither, typeMismatch, (.!=)," + , " (.:), (.:?), (.=))" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testSnippet (step (Just 80) $ fromImportAlign Group) input' +case05 = assertSnippet (step (Just 80) $ fromImportAlign Group) input' input' where -- Putting this on a different line shouldn't really help. - input' = Snippet ["import Distribution.PackageDescription.Configuration " ++ + input' = ["import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)"] -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep' (step (Just 80) $ fromImportAlign File) input' +case06 = assertSnippet (step (Just 80) $ fromImportAlign File) input' input' where input' = [ "import Bar.Qux" @@ -182,20 +174,15 @@ case06 = input' @=? testStep' (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = - expected @=? testSnippet (step (Just 80) $ fromImportAlign File) input' - where - input' = Snippet - [ "import Bar.Qux" - , "" - , "import qualified Foo.Bar" - ] - - expected = Snippet - [ "import Bar.Qux" - , "" - , "import qualified Foo.Bar" - ] +case07 = assertSnippet (step (Just 80) $ fromImportAlign File) + [ "import Bar.Qux" + , "" + , "import qualified Foo.Bar" + ] + [ "import Bar.Qux" + , "" + , "import qualified Foo.Bar" + ] -------------------------------------------------------------------------------- @@ -204,24 +191,22 @@ case08 = let options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail," - , " (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 80) options) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- @@ -230,23 +215,21 @@ case08b = let options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input - where - expected = Snippet - ["module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 80) options) input + ["module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- @@ -255,35 +238,33 @@ case09 = let options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List" - , " ( concat" - , " , foldl" - , " , foldr" - , " , head" - , " , init" - , " , last" - , " , length" - , " , map" - , " , null" - , " , reverse" - , " , tail" - , " , (++)" - , " )" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 80) options) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- @@ -292,40 +273,38 @@ case10 = let options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 40) options) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List" - , " ( concat" - , " , foldl" - , " , foldr" - , " , head" - , " , init" - , " , last" - , " , length" - , " , map" - , " , null" - , " , reverse" - , " , tail" - , " , (++)" - , " )" - , "import Data.Map" - , " ( Map" - , " , insert" - , " , lookup" - , " , (!)" - , " )" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 40) options) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map" + , " ( Map" + , " , insert" + , " , lookup" + , " , (!)" + , " )" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] @@ -335,53 +314,48 @@ case11 = let options = Options Group NewLine True Inline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List" - , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," - , " (++))" - , "import Data.Map" - , " (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances" - , " ()" - , "" - , "import Foo" - , " (Bar (..))" - , "import Herp.Derp.Internals hiding" - , " (foo)" - - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 80) options) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map" + , " (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances" + , " ()" + , "" + , "import Foo" + , " (Bar (..))" + , "import Herp.Derp.Internals hiding" + , " (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] case11b :: Assertion case11b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init, last," - , " length, map, null, reverse, tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] + assertSnippet (step (Just 80) options) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last," + , " length, map, null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- @@ -390,16 +364,12 @@ case12 = let options = Options Group NewLine True Inline Inherit (LPConstant 2) True False in - expected @=? testSnippet (step (Just 80) options) input' - where - input' = Snippet - [ "import Data.List (map)" - ] - - expected = Snippet - [ "import Data.List" - , " (map)" - ] + assertSnippet (step (Just 80) options) + [ "import Data.List (map)" + ] + [ "import Data.List" + , " (map)" + ] -------------------------------------------------------------------------------- @@ -408,11 +378,9 @@ case12b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False in - expected @=? testStep' (step (Just 80) options) input' - where - input' = ["import Data.List (map)"] - - expected = input' + assertSnippet (step (Just 80) options) + ["import Data.List (map)"] + ["import Data.List (map)"] -------------------------------------------------------------------------------- @@ -421,38 +389,28 @@ case13 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input' - where - input' = Snippet - [ "import qualified Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail, (++))" - ] - - expected = Snippet - [ "import qualified Data.List as List" - , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," - , " (++))" - ] - + assertSnippet (step (Just 80) options) + [ "import qualified Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail, (++))" + ] + [ "import qualified Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + ] --------------------------------------------------------------------------------- case13b :: Assertion case13b = let options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input' - where - input' = Snippet - [ "import qualified Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail, (++))" - ] - - expected = Snippet - [ "import qualified Data.List as List" - , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," - , " (++))" - ] + assertSnippet (step (Just 80) options) + [ "import qualified Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail, (++))" + ] + [ "import qualified Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + ] -------------------------------------------------------------------------------- @@ -461,11 +419,11 @@ case14 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False in - expected @=? testSnippet (step (Just 80) options) expected - where - expected = Snippet - [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" - ] + assertSnippet (step (Just 80) options) + [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" + ] + [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" + ] -------------------------------------------------------------------------------- @@ -474,27 +432,23 @@ case15 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input' - where - expected = Snippet - [ "import Data.Acid (AcidState)" - , "import qualified Data.Acid as Acid" - , " ( closeAcidState" - , " , createCheckpoint" - , " , openLocalStateFrom" - , " )" - , "import Data.Default.Class (Default (def))" - , "" - , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" - ] - - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" - , "import Data.Default.Class (Default (def))" - , "" - , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" - ] + assertSnippet (step (Just 80) options) + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" + ] + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" + ] -------------------------------------------------------------------------------- @@ -503,25 +457,21 @@ case16 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False in - expected @=? testSnippet (step (Just 80) options) input' - where - expected = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Maybe (Maybe(Just, Nothing))" - , "" - , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" - ] - - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Maybe (Maybe (Just, Nothing))" - , "" - , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" - ] + assertSnippet (step (Just 80) options) + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + ] + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" + ] -------------------------------------------------------------------------------- @@ -530,19 +480,15 @@ case17 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 80) options) input' - where - expected = Snippet - [ "import Control.Applicative (Applicative (pure, (<*>)))" - , "" - , "import Data.Identity (Identity (Identity, runIdentity))" - ] - - input' = Snippet - [ "import Control.Applicative (Applicative ((<*>),pure))" - , "" - , "import Data.Identity (Identity (runIdentity,Identity))" - ] + assertSnippet (step (Just 80) options) + [ "import Control.Applicative (Applicative ((<*>),pure))" + , "" + , "import Data.Identity (Identity (runIdentity,Identity))" + ] + [ "import Control.Applicative (Applicative (pure, (<*>)))" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + ] -------------------------------------------------------------------------------- @@ -551,29 +497,25 @@ case18 = let options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False in - expected @=? testSnippet (step (Just 40) options) input' - where - expected = Snippet - ---------------------------------------- - [ "import Data.Foo as Foo (Bar, Baz, Foo)" - , "" - , "import Data.Identity" - , " (Identity (Identity, runIdentity))" - , "" - , "import Data.Acid as Acid" - , " ( closeAcidState" - , " , createCheckpoint" - , " , openLocalStateFrom" - , " )" - ] - - input' = Snippet - [ "import Data.Foo as Foo (Bar, Baz, Foo)" - , "" - , "import Data.Identity (Identity (Identity, runIdentity))" - , "" - , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" - ] + assertSnippet (step (Just 40) options) + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" + ] + ---------------------------------------- + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity" + , " (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + ] -------------------------------------------------------------------------------- @@ -582,74 +524,62 @@ case19 = let options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False in - expected @=? testSnippet (step (Just 40) options) case19input - where - expected = Snippet - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding" + , " (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19b :: Assertion case19b = let options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False in - expected @=? testSnippet (step (Just 40) options) case19input - where - expected = Snippet - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19c :: Assertion case19c = let options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False in - expected @=? testSnippet (step (Just 40) options) case19input - where - expected = Snippet - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19d :: Assertion case19d = let options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False in - expected @=? testSnippet (step (Just 40) options) case19input - where - expected = Snippet - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding" + , " (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19input :: Snippet case19input = Snippet @@ -681,60 +611,53 @@ case20 = expected -------------------------------------------------------------------------------- case21 :: Assertion -case21 = expected - @=? testSnippet (step (Just 80) defaultOptions) input' - where - expected = Snippet - [ "{-# LANGUAGE ExplicitNamespaces #-}" - , "import X1 (A, B, C)" - , "import X2 (A, B, C)" - , "import X3 (A (..))" - , "import X4 (A (..))" - , "import X5 (A (..))" - , "import X6 (A (a, b, c), B (m, n, o))" - , "import X7 (a, b, c)" - , "import X8 (type (+), (+))" - , "import X9 hiding (x, y, z)" - ] - input' = Snippet - [ "{-# LANGUAGE ExplicitNamespaces #-}" - , "import X1 (A, B, A, C, A, B, A)" - , "import X2 (C(), B(), A())" - , "import X3 (A(..))" - , "import X4 (A, A(..))" - , "import X5 (A(..), A(x))" - , "import X6 (A(a,b), B(m,n), A(c), B(o))" - , "import X7 (a, b, a, c)" - , "import X8 (type (+), (+))" - , "import X9 hiding (x, y, z, x)" - ] +case21 = + assertSnippet (step (Just 80) defaultOptions) + [ "{-# LANGUAGE ExplicitNamespaces #-}" + , "import X1 (A, B, A, C, A, B, A)" + , "import X2 (C(), B(), A())" + , "import X3 (A(..))" + , "import X4 (A, A(..))" + , "import X5 (A(..), A(x))" + , "import X6 (A(a,b), B(m,n), A(c), B(o))" + , "import X7 (a, b, a, c)" + , "import X8 (type (+), (+))" + , "import X9 hiding (x, y, z, x)" + ] + [ "{-# LANGUAGE ExplicitNamespaces #-}" + , "import X1 (A, B, C)" + , "import X2 (A, B, C)" + , "import X3 (A (..))" + , "import X4 (A (..))" + , "import X5 (A (..))" + , "import X6 (A (a, b, c), B (m, n, o))" + , "import X7 (a, b, c)" + , "import X8 (type (+), (+))" + , "import X9 hiding (x, y, z)" + ] -------------------------------------------------------------------------------- case22 :: Assertion -case22 = expected - @=? testSnippet (step (Just 80) defaultOptions) input' - where - expected = Snippet - [ "{-# LANGUAGE PackageImports #-}" - , "import A" - , "import \"blah\" A" - , "import \"foo\" A" - , "import qualified \"foo\" A as X" - , "import \"foo\" B (shortName, someLongName, someLongerName," - , " theLongestNameYet)" - ] - input' = Snippet - [ "{-# LANGUAGE PackageImports #-}" - , "import A" - , "import \"foo\" A" - , "import \"blah\" A" - , "import qualified \"foo\" A as X" - -- this import fits into 80 chats without "foo", - -- but doesn't fit when "foo" is included into the calculation - , "import \"foo\" B (someLongName, someLongerName, " ++ - "theLongestNameYet, shortName)" - ] +case22 = assertSnippet (step (Just 80) defaultOptions) + [ "{-# LANGUAGE PackageImports #-}" + , "import A" + , "import \"foo\" A" + , "import \"blah\" A" + , "import qualified \"foo\" A as X" + -- this import fits into 80 chats without "foo", + -- but doesn't fit when "foo" is included into the calculation + , "import \"foo\" B (someLongName, someLongerName, " ++ + "theLongestNameYet, shortName)" + ] + [ "{-# LANGUAGE PackageImports #-}" + , "import A" + , "import \"blah\" A" + , "import \"foo\" A" + , "import qualified \"foo\" A as X" + , "import \"foo\" B (shortName, someLongName, someLongerName," + , " theLongestNameYet)" + ] -------------------------------------------------------------------------------- @@ -743,27 +666,23 @@ case23 = let options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True in - expected @=? testSnippet (step (Just 40) options) input' - where - expected = Snippet - ---------------------------------------- - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class ( Default (def) )" - , "" - , "import Data.Monoid ( (<>) )" - , "" - , "import Data.ALongName.Foo ( Boo, Foo," - , " Goo )" - ] - - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Monoid ((<>) )" - , "" - , "import Data.ALongName.Foo (Foo, Goo, Boo)" - ] + assertSnippet (step (Just 40) options) + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Monoid ((<>) )" + , "" + , "import Data.ALongName.Foo (Foo, Goo, Boo)" + ] + ---------------------------------------- + [ "import Data.Acid ( AcidState )" + , "import Data.Default.Class ( Default (def) )" + , "" + , "import Data.Monoid ( (<>) )" + , "" + , "import Data.ALongName.Foo ( Boo, Foo," + , " Goo )" + ] -------------------------------------------------------------------------------- @@ -772,28 +691,24 @@ case23b = let options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True in - expected @=? testSnippet (step (Just 40) options) input' - where - expected = Snippet - ---------------------------------------- - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class" - , " ( Default (def) )" - , "" - , "import Data.Monoid ( (<>) )" - , "" - , "import Data.ALongName.Foo ( Boo, Foo," - , " Goo )" - ] - - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Monoid ((<>) )" - , "" - , "import Data.ALongName.Foo (Foo, Goo, Boo)" - ] + assertSnippet (step (Just 40) options) + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Monoid ((<>) )" + , "" + , "import Data.ALongName.Foo (Foo, Goo, Boo)" + ] + ---------------------------------------- + [ "import Data.Acid ( AcidState )" + , "import Data.Default.Class" + , " ( Default (def) )" + , "" + , "import Data.Monoid ( (<>) )" + , "" + , "import Data.ALongName.Foo ( Boo, Foo," + , " Goo )" + ] -------------------------------------------------------------------------------- @@ -802,26 +717,22 @@ case24 = let options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True in - expected @=? testSnippet (step (Just 40) options) input' - where - expected = Snippet - ---------------------------------------- - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class" - , " ( Default (def) )" - , "" - , "import Data.ALongName.Foo" - , " ( BooReallyLong, FooReallyLong," - , " GooReallyLong )" - ] - - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.ALongName.Foo (FooReallyLong, " ++ - "GooReallyLong, BooReallyLong)" - ] + assertSnippet (step (Just 40) options) + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.ALongName.Foo (FooReallyLong, " ++ + "GooReallyLong, BooReallyLong)" + ] + ---------------------------------------- + [ "import Data.Acid ( AcidState )" + , "import Data.Default.Class" + , " ( Default (def) )" + , "" + , "import Data.ALongName.Foo" + , " ( BooReallyLong, FooReallyLong," + , " GooReallyLong )" + ] -------------------------------------------------------------------------------- @@ -830,107 +741,96 @@ case25 = let options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False in - expected @=? testSnippet (step (Just 80) options) input' - where - expected = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Maybe (Maybe(Just, Nothing))" - , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" - , "" - , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" - ] - input' = Snippet - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Maybe (Maybe (Just, Nothing))" - , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" - , "" - , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" - ] + assertSnippet (step (Just 80) options) + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + ] + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe(Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" + ] -------------------------------------------------------------------------------- case26 :: Assertion -case26 = expected - @=? testSnippet (step (Just 80) options ) input' +case26 = + assertSnippet (step (Just 80) options) + ["import Data.List"] + ["import Data.List"] where options = defaultOptions { listAlign = NewLine, longListAlign = Multiline } - input' = Snippet ["import Data.List"] - expected = Snippet ["import Data.List"] -------------------------------------------------------------------------------- case27 :: Assertion -case27 = expected @=? testSnippet (step Nothing $ fromImportAlign Global) input - where - expected = Snippet - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail, (++))" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "import Only.Instances ()" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] +case27 = assertSnippet (step Nothing $ fromImportAlign Global) input + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] -------------------------------------------------------------------------------- case28 :: Assertion -case28 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input' - where - expected = Snippet - [ "import Control.Monad" - , "import qualified Data.Aeson as JSON" - , "import Data.Default.Class (Default (def))" - , "" - , "import Data.Maybe (Maybe (Just, Nothing))" - , "import qualified Data.Maybe.Extra (Maybe (Just, Nothing))" - , "" - , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" - , "import Data.Set (empty, intersect, nub)" - ] - input' = Snippet - [ "import Data.Default.Class (Default(def))" - , "import qualified Data.Aeson as JSON" - , "import qualified Data.Aeson as JSON" - , "import Control.Monad" - , "import Control.Monad" - , "" - , "import Data.Maybe (Maybe (Just, Nothing))" - , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" - , "" - , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" - , "import Data.Foo (Foo (Foo,Bar))" - , "import Data.Set (empty, intersect)" - , "import Data.Set (empty, nub)" - ] +case28 = assertSnippet (step (Just 80) $ fromImportAlign Global) + [ "import Data.Default.Class (Default(def))" + , "import qualified Data.Aeson as JSON" + , "import qualified Data.Aeson as JSON" + , "import Control.Monad" + , "import Control.Monad" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + , "import Data.Foo (Foo (Foo,Bar))" + , "import Data.Set (empty, intersect)" + , "import Data.Set (empty, nub)" + ] + [ "import Control.Monad" + , "import qualified Data.Aeson as JSON" + , "import Data.Default.Class (Default (def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import qualified Data.Maybe.Extra (Maybe (Just, Nothing))" + , "" + , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" + , "import Data.Set (empty, intersect, nub)" + ] -------------------------------------------------------------------------------- case29 :: Assertion -case29 = expected @=? testSnippet (step Nothing $ fromImportAlign Group) input' - where +case29 = assertSnippet (step Nothing $ fromImportAlign Group) -- Check that "Group" mode recognizes groups with multi-line imports - input' = Snippet - [ "import Foo (foo)" - , "import BarBar ( bar" - , " , kek)" - , "import Abcd ()" - , "" - , "import A (A)" - ] - expected = Snippet - [ "import Abcd ()" - , "import BarBar (bar, kek)" - , "import Foo (foo)" - , "" - , "import A (A)" - ] \ No newline at end of file + [ "import Foo (foo)" + , "import BarBar ( bar" + , " , kek)" + , "import Abcd ()" + , "" + , "import A (A)" + ] + [ "import Abcd ()" + , "import BarBar (bar, kek)" + , "import Foo (foo)" + , "" + , "import A (A)" + ] -- cgit v1.2.3 From e6ab900570c987b40135d10ee881ffc375369ad5 Mon Sep 17 00:00:00 2001 From: Łukasz Gołębiewski Date: Mon, 5 Oct 2020 12:23:14 +0200 Subject: Bump cabal version to 2.4 * This is the newest cabal version supported by stack * Remove warning about missing Default-language field * Remove warning regarding the License field --- stylish-haskell.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index ebce872..05b9634 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,15 +1,15 @@ +Cabal-version: 2.4 Name: stylish-haskell Version: 0.12.0.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell -License: BSD3 +License: BSD-3-Clause License-file: LICENSE Author: Jasper Van der Jeugt Maintainer: Jasper Van der Jeugt Copyright: 2012 Jasper Van der Jeugt Category: Language Build-type: Simple -Cabal-version: >= 1.10 Description: A Haskell code prettifier. For more information, see: -- cgit v1.2.3 From 8d00bd6a7ecaddf626844dd59eddcb25ea768090 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 5 Oct 2020 12:54:50 +0200 Subject: Bump version to 0.12.1.0 --- CHANGELOG | 4 ++++ stylish-haskell.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 2981385..602ce10 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # CHANGELOG +- 0.12.1.0 (2020-10-05) + * Bump Cabal-version to 2.4 (by Łukasz Gołębiewski) + * Fix "group" import sort with multi-line imports (by Maxim Koltsov) + - 0.12.0.0 (2020-10-02) * Use ghc-lib-parser rather than haskell-src-exts diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 05b9634..9109c61 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: stylish-haskell -Version: 0.12.0.0 +Version: 0.12.1.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD-3-Clause -- cgit v1.2.3 From 062310c5d3420e58edea1a2d6bbe0f71d18a184e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 5 Oct 2020 12:56:54 +0200 Subject: Fix Autogen-modules issue in cabal file --- stylish-haskell.cabal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 9109c61..1ae914e 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -57,6 +57,9 @@ Library Language.Haskell.Stylish.Verbose Paths_stylish_haskell + Autogen-modules: + Paths_stylish_haskell + Build-depends: aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, @@ -150,6 +153,9 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Verbose Paths_stylish_haskell + Autogen-modules: + Paths_stylish_haskell + Build-depends: HUnit >= 1.2 && < 1.7, test-framework >= 0.4 && < 0.9, -- cgit v1.2.3 From 84ff4e57eb24b5b5ab95ad7b64419846922e00f7 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 5 Oct 2020 21:28:37 +0300 Subject: Make sorting deriving list optional (#316) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Make sorting deriving list optional Not everyone wants their typeclasses sorted. * Remove redundant code Co-authored-by: Łukasz Gołębiewski --- data/stylish-haskell.yaml | 7 +++++-- lib/Language/Haskell/Stylish/Config.hs | 1 + lib/Language/Haskell/Stylish/Step/Data.hs | 4 +++- tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 23 ++++++++++++++++++----- 4 files changed, 27 insertions(+), 8 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 80892dc..0a2e21a 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -58,10 +58,13 @@ steps: # # # How many spaces to insert before "via" clause counted from indentation of deriving clause # # Possible values: - # # - "same_line" -- "{" and first field goes on the same line as the data constructor. - # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. # via: "indent 2" # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # # # Wheter or not to break enums onto several lines # # # # Default: false diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 333736f..68638a6 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -221,6 +221,7 @@ parseRecords c o = Data.step <*> (o A..:? "break_single_constructors" A..!= True) <*> (o A..: "via" >>= parseIndent) <*> (o A..:? "curried_context" A..!= False) + <*> (o A..:? "sort_deriving" A..!= True) <*> pure configMaxColumns) where configMaxColumns = diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index bf39c7c..523389b 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -71,6 +71,8 @@ data Config = Config -- ^ Indentation between @via@ clause and start of deriving column start , cCurriedContext :: !Bool -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + , cSortDeriving :: !Bool + -- ^ If true, will sort type classes in a @deriving@ list. , cMaxColumns :: !MaxColumns } deriving (Show) @@ -266,7 +268,7 @@ putDeriving Config{..} (L pos clause) = do = clause & deriv_clause_tys & unLocated - & sortBy compareOutputable + & (if cSortDeriving then sortBy compareOutputable else id) & fmap hsib_body headTy = diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 4357af6..9ed9d0d 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -65,6 +65,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 52" case52 , testCase "case 53" case53 , testCase "case 54" case54 + , testCase "case 55" case55 ] case00 :: Assertion @@ -1200,17 +1201,29 @@ case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumn , " deriving newtype (Applicative, Functor, Monad)" ] +case55 :: Assertion +case55 = expected @=? testStep (step sameSameNoSortStyle) input + where + input = unlines + [ "data Foo = Foo deriving (Z, Y, X, Bar, Abcd)" + ] + + expected = input + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False NoMaxColumns +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns + +sameSameNoSortStyle :: Config +sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns -- cgit v1.2.3 From 70a7755719061e4b280a07578c6135762095e879 Mon Sep 17 00:00:00 2001 From: Łukasz Gołębiewski Date: Tue, 6 Oct 2020 15:03:59 +0200 Subject: Add nix shell --- default.nix | 10 ++++++++++ haskell-pkgs.nix | 18 ++++++++++++++++++ shell.nix | 27 +++++++++++++++++++++++++++ 3 files changed, 55 insertions(+) create mode 100644 default.nix create mode 100644 haskell-pkgs.nix create mode 100644 shell.nix diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..c870da5 --- /dev/null +++ b/default.nix @@ -0,0 +1,10 @@ +{ pkgs ? import ./haskell-pkgs.nix +, haskellCompiler ? "ghc8101" +}: +pkgs.haskell-nix.cabalProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { + name = "stylish-haskell"; + src = ./.; + }; + compiler-nix-name = haskellCompiler; +} diff --git a/haskell-pkgs.nix b/haskell-pkgs.nix new file mode 100644 index 0000000..729c2aa --- /dev/null +++ b/haskell-pkgs.nix @@ -0,0 +1,18 @@ +let + # Fetch the latest haskell.nix and import its default.nix + haskellNix = import (builtins.fetchTarball{ + url = "https://github.com/input-output-hk/haskell.nix/archive/f6663a8449f5e4a7393aa24601600c8f6e352c97.tar.gz"; + }) {}; + +# haskell.nix provides access to the nixpkgs pins which are used by our CI, +# hence you will be more likely to get cache hits when using these. +# But you can also just use your own, e.g. ''. + nixpkgsSrc = haskellNix.sources.nixpkgs-2003; + +# haskell.nix provides some arguments to be passed to nixpkgs, including some +# patches and also the haskell.nix functionality itself as an overlay. + nixpkgsArgs = haskellNix.nixpkgsArgs; + +# import nixpkgs with overlays +in + import nixpkgsSrc nixpkgsArgs diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..4614cc3 --- /dev/null +++ b/shell.nix @@ -0,0 +1,27 @@ +{ pkgs ? import ./haskell-pkgs.nix}: + +let + hsPkgs = import ./. { inherit pkgs; }; +in + hsPkgs.shellFor { + # Include only the *local* packages of your project. + # packages = ps: with ps; [ + # ]; + + # Builds a Hoogle documentation index of all dependencies, + # and provides a "hoogle" command to search the index. + # withHoogle = true; + + # You might want some extra tools in the shell (optional). + # Some common tools can be added with the `tools` argument + tools = { cabal = "3.2.0.0"; hlint = "2.2.11"; }; + # See overlays/tools.nix for more details + + # Some you may need to get some other way. + buildInputs = with pkgs.haskellPackages; + [ ghcid ]; + + # Prevents cabal from choosing alternate plans, so that + # *all* dependencies are provided by Nix. + exactDeps = true; + } -- cgit v1.2.3 From f6c3800c1a7896ae289374f8f637cbad25ae1f38 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 6 Oct 2020 18:05:59 +0200 Subject: Refactor Squash tests --- .../Language/Haskell/Stylish/Step/Squash/Tests.hs | 137 +++++++++------------ 1 file changed, 59 insertions(+), 78 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs index a785d9a..9139507 100644 --- a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs @@ -1,13 +1,14 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Squash.Tests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -28,94 +29,74 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleSquash.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep step input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] +case01 = assertSnippet step + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep step input - where - input = unlines - [ "data Foo = Foo" - , " { fooqux" - , " , bar :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { fooqux" - , " , bar :: String" - , " } deriving (Show)" - ] +case02 = assertSnippet step + [ "data Foo = Foo" + , " { fooqux" + , " , bar :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { fooqux" + , " , bar :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing -> y0" - , " Just x -> f x" - ] - - expected = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing -> y0" - , " Just x -> f x" - ] +case03 = assertSnippet step + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing -> y0" + , " Just x -> f x" + ] + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing -> y0" + , " Just x -> f x" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing ->" - , " y0" - , " Just x ->" - , " f x" - ] - - expected = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing ->" - , " y0" - , " Just x ->" - , " f x" - ] +case04 = assertSnippet step + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing ->" + , " y0" + , " Just x ->" + , " f x" + ] + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing ->" + , " y0" + , " Just x ->" + , " f x" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 _ Nothing = y" - , "maybe _ f (Just x) = f x" - ] - - expected = unlines - [ "maybe y0 _ Nothing = y" - , "maybe _ f (Just x) = f x" - ] +case05 = assertSnippet step + [ "maybe y0 _ Nothing = y" + , "maybe _ f (Just x) = f x" + ] + [ "maybe y0 _ Nothing = y" + , "maybe _ f (Just x) = f x" + ] -- cgit v1.2.3 From 986cea995f0272f4db470b24bf390ffc8edaeb00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 12:54:13 +0200 Subject: Imports: Respect separate_lists for (..) imports Fixes #320 --- lib/Language/Haskell/Stylish/Step/Imports.hs | 6 +++--- tests/Language/Haskell/Stylish/Step/Imports/Tests.hs | 8 ++++++++ 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 9c1d82d..f2439dc 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -309,13 +309,13 @@ printQualified Options{..} padNames stats (L _ decl) = do -------------------------------------------------------------------------------- printImport :: Options -> IE GhcPs -> P () -printImport Options{..} (IEVar _ name) = do +printImport _ (IEVar _ name) = do printIeWrappedName name printImport _ (IEThingAbs _ name) = do printIeWrappedName name -printImport _ (IEThingAll _ name) = do +printImport Options{..} (IEThingAll _ name) = do printIeWrappedName name - space + when separateLists space putText "(..)" printImport _ (IEModuleContents _ (L _ m)) = do putText (moduleNameString m) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 6521a8e..6889db4 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -61,6 +61,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 + , testCase "case 30" case30 ] @@ -834,3 +835,10 @@ case29 = assertSnippet (step Nothing $ fromImportAlign Group) , "" , "import A (A)" ] + + +-------------------------------------------------------------------------------- +case30 :: Assertion +case30 = assertSnippet (step Nothing defaultOptions {separateLists = False}) + ["import Data.Monoid (Monoid (..))"] + ["import Data.Monoid (Monoid(..))"] -- cgit v1.2.3 From 10ce71bb79cf9f6ab47ac9dfef503529c41bef00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 12:55:32 +0200 Subject: ModuleHeader: Add separate_lists option See #320 --- data/stylish-haskell.yaml | 3 +++ lib/Language/Haskell/Stylish/Config.hs | 7 +++++-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 18 ++++++++++-------- .../Haskell/Stylish/Step/ModuleHeader/Tests.hs | 12 ++++++++++++ 4 files changed, 30 insertions(+), 10 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 0a2e21a..e0a739c 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -27,6 +27,9 @@ steps: # # Should export lists be sorted? Sorting is only performed within the # # export section, as delineated by Haddock comments. # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true # Format record definitions. This is disabled by default. # diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 68638a6..36688a5 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -195,8 +195,11 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config - <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig) - <*> o A..:? "sort" A..!= (ModuleHeader.sort ModuleHeader.defaultConfig) + <$> o A..:? "indent" A..!= ModuleHeader.indent def + <*> o A..:? "sort" A..!= ModuleHeader.sort def + <*> o A..:? "separate_lists" A..!= ModuleHeader.separateLists def + where + def = ModuleHeader.defaultConfig -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 90f3478..0c33298 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -40,16 +40,16 @@ import Language.Haskell.Stylish.Step data Config = Config - -- TODO(jaspervdj): Use the same sorting as in `Imports`? - -- TODO: make sorting optional? - { indent :: Int - , sort :: Bool + { indent :: Int + , sort :: Bool + , separateLists :: Bool } defaultConfig :: Config defaultConfig = Config - { indent = 4 - , sort = True + { indent = 4 + , sort = True + , separateLists = True } step :: Config -> Step @@ -218,13 +218,15 @@ printExportList conf (L srcLoc exports) = do printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] printExportsGroupTail [] = pure () + -- NOTE(jaspervdj): This code is almost the same as the import printing + -- in 'Imports' and should be merged. printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of IEVar _ name -> putOutputable name IEThingAbs _ name -> putOutputable name IEThingAll _ name -> do putOutputable name - space + when (separateLists conf) space putText "(..)" IEModuleContents _ (L _ m) -> do putText "module" @@ -232,7 +234,7 @@ printExportList conf (L srcLoc exports) = do putText (showOutputable m) IEThingWith _ name _wildcard imps _ -> do putOutputable name - space + when (separateLists conf) space putText "(" sep (comma >> space) $ fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index b6d6b89..002be7c 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -34,6 +34,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Indents with 2 spaces" ex14 , testCase "Group doc with 2 spaces" ex15 , testCase "Does not sort" ex16 + , testCase "Repects separate_lists" ex17 ] -------------------------------------------------------------------------------- @@ -299,3 +300,14 @@ ex16 = assertSnippet (step defaultConfig {sort = False}) input input , " , no" , " ) where" ] + +ex17 :: Assertion +ex17 = assertSnippet (step defaultConfig {separateLists = False}) + [ "module Foo" + , " ( Bar (..)" + , " ) where" + ] + [ "module Foo" + , " ( Bar(..)" + , " ) where" + ] -- cgit v1.2.3 From 1f7f23db8ab5c048b837140d9633a82b1e642bae Mon Sep 17 00:00:00 2001 From: Łukasz Gołębiewski Date: Wed, 7 Oct 2020 13:20:15 +0200 Subject: Refactor UnicodeSyntax.hs (#317) * Refactor UnicodeSyntax.hs Co-authored-by: Jasper Van der Jeugt --- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 42 ++++++---------------- 1 file changed, 10 insertions(+), 32 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 2f0def6..ff01dee 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -52,37 +52,17 @@ groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] groupPerLine = M.toList . M.fromListWith (++) . map (\((r, c), x) -> (r, [(c, x)])) - --------------------------------------------------------------------------------- -typeSigs :: Module -> Lines -> [((Int, Int), String)] -typeSigs module' ls = - [ (pos, "::") +-- | Find symbol positions in the module. Currently only searches in type +-- signatures. +findSymbol :: Module -> Lines -> String -> [((Int, Int), String)] +findSymbol module' ls sym = + [ (pos, sym) | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (_, funEnd) <- infoPoints funLoc - , (typeStart, _) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between funEnd typeStart "::" ls - ] - --------------------------------------------------------------------------------- -contexts :: Module -> Lines -> [((Int, Int), String)] -contexts module' ls = - [ (pos, "=>") - | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (start, end) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between start end "=>" ls + , (funStart, _) <- infoPoints funLoc + , (_, typeEnd) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between funStart typeEnd sym ls ] - --------------------------------------------------------------------------------- -typeFuns :: Module -> Lines -> [((Int, Int), String)] -typeFuns module' ls = - [ (pos, "->") - | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (start, end) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between start end "->" ls - ] - - -------------------------------------------------------------------------------- -- | Search for a needle in a haystack of lines. Only part the inside (startRow, -- startCol), (endRow, endCol) is searched. The return value is the position of @@ -113,7 +93,5 @@ step' alp lg ls module' = applyChanges changes ls where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ replaceAll perLine - perLine = sort $ groupPerLine $ - typeSigs module' ls ++ - contexts module' ls ++ - typeFuns module' ls + toReplace = [ "::", "=>", "->" ] + perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace -- cgit v1.2.3 From 1bc2b2c5c3377ed7fe55d53175580eccebb631aa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 20:37:43 +0200 Subject: ModuleHeader: reuse printImport from Imports --- lib/Language/Haskell/Stylish/Step/Imports.hs | 13 ++-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 72 +++++++---------------- 2 files changed, 31 insertions(+), 54 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index f2439dc..b89d73f 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -11,6 +11,8 @@ module Language.Haskell.Stylish.Step.Imports , EmptyListAlign (..) , ListPadding (..) , step + + , printImport ) where -------------------------------------------------------------------------------- @@ -213,7 +215,7 @@ printQualified Options{..} padNames stats (L _ decl) = do _ -> space >> putText "()" Just (L _ imports) -> do let printedImports = flagEnds $ -- [P ()] - fmap ((printImport Options{..}) . unLocated) + fmap ((printImport separateLists) . unLocated) (prepareImportList imports) -- Since we might need to output the import module name several times, we @@ -308,18 +310,20 @@ printQualified Options{..} padNames stats (L _ decl) = do -------------------------------------------------------------------------------- -printImport :: Options -> IE GhcPs -> P () +printImport :: Bool -> IE GhcPs -> P () printImport _ (IEVar _ name) = do printIeWrappedName name printImport _ (IEThingAbs _ name) = do printIeWrappedName name -printImport Options{..} (IEThingAll _ name) = do +printImport separateLists (IEThingAll _ name) = do printIeWrappedName name when separateLists space putText "(..)" printImport _ (IEModuleContents _ (L _ m)) = do + putText "module" + space putText (moduleNameString m) -printImport Options{..} (IEThingWith _ name _wildcard imps _) = do +printImport separateLists (IEThingWith _ name _wildcard imps _) = do printIeWrappedName name when separateLists space parenthesize $ @@ -333,6 +337,7 @@ printImport _ (IEDocNamed _ _) = printImport _ (XIE ext) = GHC.noExtCon ext + -------------------------------------------------------------------------------- printIeWrappedName :: LIEWrappedName RdrName -> P () printIeWrappedName lie = unLocated lie & \case diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 0c33298..728ce4a 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -7,27 +7,26 @@ module Language.Haskell.Stylish.Step.ModuleHeader ) where -------------------------------------------------------------------------------- -import ApiAnnotation (AnnKeywordId (..), - AnnotationComment (..)) -import Control.Monad (forM_, join, when) -import Data.Bifunctor (second) -import Data.Foldable (find, toList) -import Data.Function (on, (&)) -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (isJust, listToMaybe) -import qualified GHC.Hs.Doc as GHC -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp (IE (..)) -import qualified GHC.Hs.ImpExp as GHC -import qualified Module as GHC -import SrcLoc (GenLocated (..), Located, - RealLocated, SrcSpan (..), - srcSpanEndLine, - srcSpanStartLine, unLoc) -import Util (notNull) +import ApiAnnotation (AnnKeywordId (..), + AnnotationComment (..)) +import Control.Monad (forM_, join, when) +import Data.Bifunctor (second) +import Data.Foldable (find, toList) +import Data.Function ((&)) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust, listToMaybe) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (GenLocated (..), + Located, RealLocated, + SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine, unLoc) +import Util (notNull) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -37,6 +36,7 @@ import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import qualified Language.Haskell.Stylish.Step.Imports as Imports data Config = Config @@ -221,32 +221,4 @@ printExportList conf (L srcLoc exports) = do -- NOTE(jaspervdj): This code is almost the same as the import printing -- in 'Imports' and should be merged. printExport :: GHC.LIE GhcPs -> P () - printExport (L _ export) = case export of - IEVar _ name -> putOutputable name - IEThingAbs _ name -> putOutputable name - IEThingAll _ name -> do - putOutputable name - when (separateLists conf) space - putText "(..)" - IEModuleContents _ (L _ m) -> do - putText "module" - space - putText (showOutputable m) - IEThingWith _ name _wildcard imps _ -> do - putOutputable name - when (separateLists conf) space - putText "(" - sep (comma >> space) $ - fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps - putText ")" - IEGroup _ _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export - IEDoc _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export - IEDocNamed _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export - XIE ext -> - GHC.noExtCon ext + printExport = Imports.printImport (separateLists conf) . unLoc -- cgit v1.2.3 From 0e2ebd1722871dce2207b44266a6e4420c13a588 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 21:53:36 +0200 Subject: Fix some issues with record field padding See #318 and #319 --- lib/Language/Haskell/Stylish/Printer.hs | 8 + lib/Language/Haskell/Stylish/Step/Data.hs | 84 ++++++--- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 4 +- tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 204 ++++++++++++++-------- 4 files changed, 198 insertions(+), 102 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 886f912..a7ddf5e 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -44,6 +44,7 @@ module Language.Haskell.Stylish.Printer , space , spaces , suffix + , pad -- ** Advanced combinators , withColumns @@ -323,6 +324,13 @@ prefix pa pb = pa >> pb suffix :: P a -> P b -> P a suffix pa pb = pb >> pa +-- | Indent to a given number of spaces. If the current line already exceeds +-- that number in length, nothing happens. +pad :: Int -> P () +pad n = do + len <- length <$> getCurrentLine + spaces $ n - len + -- | Gets comment on supplied 'line' and removes it from the state removeLineComment :: Int -> P (Maybe AnnotationComment) removeLineComment line = diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 523389b..77d12a0 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Data ( Config(..) + , defaultConfig + , Indent(..) , MaxColumns(..) , step @@ -22,19 +24,24 @@ import Data.Maybe (listToMaybe) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment) -import BasicTypes (LexicalFixity(..)) -import GHC.Hs.Decls (HsDecl(..), HsDataDefn(..)) -import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) -import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) -import GHC.Hs.Decls (ConDecl(..)) -import GHC.Hs.Extension (GhcPs, NoExtField(..), noExtCon) -import GHC.Hs.Types (ConDeclField(..), HsContext) -import GHC.Hs.Types (HsType(..), ForallVisFlag(..)) -import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) -import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) +import BasicTypes (LexicalFixity (..)) +import GHC.Hs.Decls (ConDecl (..), + DerivStrategy (..), + HsDataDefn (..), HsDecl (..), + HsDerivingClause (..), + NewOrData (..), + TyClDecl (..)) +import GHC.Hs.Extension (GhcPs, NoExtField (..), + noExtCon) +import GHC.Hs.Types (ConDeclField (..), + ForallVisFlag (..), + HsConDetails (..), HsContext, + HsImplicitBndrs (..), + HsTyVarBndr (..), + HsType (..), LHsQTyVars (..)) import RdrName (RdrName) -import SrcLoc (Located, RealLocated) -import SrcLoc (GenLocated(..)) +import SrcLoc (GenLocated (..), Located, + RealLocated) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -76,6 +83,21 @@ data Config = Config , cMaxColumns :: !MaxColumns } deriving (Show) +-- | TODO: pass in MaxColumns? +defaultConfig :: Config +defaultConfig = Config + { cEquals = Indent 4 + , cFirstField = Indent 4 + , cFieldComment = 2 + , cDeriving = 4 + , cBreakEnums = True + , cBreakSingleConstructors = False + , cVia = Indent 4 + , cSortDeriving = True + , cMaxColumns = NoMaxColumns + , cCurriedContext = False + } + step :: Config -> Step step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where @@ -190,8 +212,8 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = data DataDecl = MkDataDecl { dataDeclName :: Located RdrName , dataTypeVars :: LHsQTyVars GhcPs - , dataDefn :: HsDataDefn GhcPs - , dataFixity :: LexicalFixity + , dataDefn :: HsDataDefn GhcPs + , dataFixity :: LexicalFixity } putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P () @@ -199,10 +221,10 @@ putDeriving Config{..} (L pos clause) = do putText "deriving" forM_ (deriv_clause_strategy clause) \case - L _ StockStrategy -> space >> putText "stock" + L _ StockStrategy -> space >> putText "stock" L _ AnyclassStrategy -> space >> putText "anyclass" - L _ NewtypeStrategy -> space >> putText "newtype" - L _ (ViaStrategy _) -> pure () + L _ NewtypeStrategy -> space >> putText "newtype" + L _ (ViaStrategy _) -> pure () putCond withinColumns @@ -224,13 +246,13 @@ putDeriving Config{..} (L pos clause) = do where getType = \case - HsIB _ tp -> tp + HsIB _ tp -> tp XHsImplicitBndrs x -> noExtCon x withinColumns PrinterState{currentLine} = case cMaxColumns of MaxColumns maxCols -> length currentLine <= maxCols - NoMaxColumns -> True + NoMaxColumns -> True oneLinePrint = do space @@ -361,8 +383,10 @@ putConstructor cfg consIndent (L _ cons) = case cons of sep space (fmap putOutputable xs) RecCon (L recPos (L posFirst firstArg : args)) -> do putRdrName con_name - skipToBrace >> putText "{" + skipToBrace bracePos <- getCurrentLineLength + putText "{" + let fieldPos = bracePos + 2 space -- Unless everything's configured to be on the same line, put pending @@ -371,7 +395,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos -- Put first decl field - putConDeclField cfg firstArg + pad fieldPos >> putConDeclField cfg firstArg unless (cFirstField cfg == SameLine) (putEolComment posFirst) -- Put tail decl fields @@ -395,6 +419,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of skipToBrace >> putText "}" where + -- Jump to the first brace of the first record of the first constructor. skipToBrace = case (cEquals cfg, cFirstField cfg) of (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y (SameLine, SameLine) -> space @@ -402,12 +427,13 @@ putConstructor cfg consIndent (L _ cons) = case cons of (SameLine, Indent y) -> newline >> spaces (consIndent + y) (Indent _, SameLine) -> space + -- Jump to the next declaration. sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of (_, Indent y) | not (cBreakSingleConstructors cfg) -> y - (SameLine, SameLine) -> bracePos - 1 -- back one from brace pos to place comma + (SameLine, SameLine) -> bracePos (Indent x, Indent y) -> x + y + 2 - (SameLine, Indent y) -> bracePos - 1 + y - 2 - (Indent x, SameLine) -> bracePos - 1 + x - 2 + (SameLine, Indent y) -> bracePos + y - 2 + (Indent x, SameLine) -> bracePos + x - 2 putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () putNewtypeConstructor cfg (L _ cons) = case cons of @@ -493,7 +519,7 @@ isGADT = any isGADTCons . dd_cons . dataDefn where isGADTCons = \case L _ (ConDeclGADT {}) -> True - _ -> False + _ -> False isNewtype :: DataDecl -> Bool isNewtype = (== NewType) . dd_ND . dataDefn @@ -507,7 +533,7 @@ isEnum = all isUnary . dd_cons . dataDefn isUnary = \case L _ (ConDeclH98 {..}) -> case con_args of PrefixCon [] -> True - _ -> False + _ -> False _ -> False hasConstructors :: DataDecl -> Bool diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 728ce4a..58752fe 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -182,9 +182,7 @@ printExportList conf (L srcLoc exports) = do -- > xxxxyyfoo -- > xxxx) where doIndent = spaces (indent conf) - doHang = do - len <- length <$> getCurrentLine - spaces $ indent conf + 2 - len + doHang = pad (indent conf + 2) doSort = if sort conf then NonEmpty.sortBy compareLIE else id diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 9ed9d0d..1d50bf1 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Step.Data.Tests ( tests ) where import Language.Haskell.Stylish.Step.Data -import Language.Haskell.Stylish.Tests.Util (testStep) +import Language.Haskell.Stylish.Tests.Util (assertSnippet, testStep) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?)) @@ -66,6 +68,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 53" case53 , testCase "case 54" case54 , testCase "case 55" case55 + , testCase "case 56" case56 + , testCase "case 57" case57 ] case00 :: Assertion @@ -456,79 +460,67 @@ case20 = input @=? testStep (step indentIndentStyle) input ] case21 :: Assertion -case21 = expected @=? testStep (step sameSameStyle) input - where - input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - - expected = unlines - [ "data Foo a = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] +case21 = assertSnippet (step sameSameStyle) + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a = Foo { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case22 :: Assertion -case22 = expected @=? testStep (step sameIndentStyle) input - where - input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - - expected = unlines - [ "data Foo a = Foo" - , " { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar" - , " { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] +case22 = assertSnippet (step sameIndentStyle) + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a = Foo" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar" + , " { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case23 :: Assertion -case23 = expected @=? testStep (step indentSameStyle) input - where - input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - - expected = unlines - [ "data Foo a" - , " = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] +case23 = assertSnippet (step indentSameStyle) + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a" + , " = Foo { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case24 :: Assertion case24 = expected @=? testStep (step indentIndentStyle) input @@ -1210,6 +1202,78 @@ case55 = expected @=? testStep (step sameSameNoSortStyle) input expected = input +case56 :: Assertion +case56 = assertSnippet (step defaultConfig) + [ "data Foo = Foo" + , " { -- | Comment" + , " bar :: Int" + , " , baz :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { -- | Comment" + , " bar :: Int" + , " , baz :: Int" + , " }" + ] + +case57 :: Assertion +case57 = assertSnippet (step defaultConfig) + [ "data Foo = Foo" + , " { {- | A" + , " -}" + , " fooA :: Int" + , "" + , " {- | B" + , " -}" + , " , fooB :: Int" + , "" + , " {- | C" + , " -}" + , " , fooC :: Int" + , "" + , " {- | D" + , " -}" + , " , fooD :: Int" + , "" + , " {- | E" + , " -}" + , " , fooE :: Int" + , "" + , " {- | F" + , " -}" + , " , fooFooFoo :: Int" + , "" + , " {- | G" + , " -}" + , " , fooBarBar :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { {- | A" + , " -}" + , " fooA :: Int" + , " {- | B" + , " -}" + , " , fooB :: Int" + , " {- | C" + , " -}" + , " , fooC :: Int" + , " {- | D" + , " -}" + , " , fooD :: Int" + , " {- | E" + , " -}" + , " , fooE :: Int" + , " {- | F" + , " -}" + , " , fooFooFoo :: Int" + , " {- | G" + , " -}" + , " , fooBarBar :: Int" + , " }" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns -- cgit v1.2.3 From 9638bba137a232541e7f285cdd49b540eb010f41 Mon Sep 17 00:00:00 2001 From: 1Computer1 <22125769+1Computer1@users.noreply.github.com> Date: Thu, 8 Oct 2020 07:40:26 -0400 Subject: Add support for aligning multi way ifs --- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 38 ++++++++++++++++++++-- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 14 ++++++++ 2 files changed, 50 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index e02c270..e03f665 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -9,7 +9,7 @@ module Language.Haskell.Stylish.Step.SimpleAlign -------------------------------------------------------------------------------- import Control.Monad (guard) -import Data.List (foldl') +import Data.List (foldl', foldl1') import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -134,6 +134,39 @@ matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing +-------------------------------------------------------------------------------- +multiWayIfToAlignable + :: Config + -> Hs.LHsExpr Hs.GhcPs + -> [Alignable S.RealSrcSpan] +multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = + fromMaybe [] $ traverse (grhsToAlignable conf) grhss +multiWayIfToAlignable _conf _ = [] + + +-------------------------------------------------------------------------------- +grhsToAlignable + :: Config + -> S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable S.RealSrcSpan) +grhsToAlignable conf (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do + guard $ cCases conf + let guardsLocs = map S.getLoc guards + bodyLoc = S.getLoc body + left = foldl1' S.combineSrcSpans guardsLocs + matchPos <- toRealSrcSpan grhsloc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos + , aRightLead = length "-> " + } +grhsToAlignable _conf (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable _conf (S.L _ _) = Nothing + + -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step step maxColumns config = makeStep "Cases" $ \ls module' -> @@ -147,5 +180,6 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> configured :: [Change String] configured = concat $ [changes records recordToAlignable | cRecords config] ++ - [changes everything (matchGroupToAlignable config)] in + [changes everything (matchGroupToAlignable config)] ++ + [changes everything (multiWayIfToAlignable config)] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index fa17784..5b502d1 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -31,6 +31,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 + , testCase "case 13" case13 ] @@ -199,3 +200,16 @@ case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input , " Just y -> 1" , " Nothing -> 2" ] + + +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = assertSnippet (step Nothing defaultConfig) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] -- cgit v1.2.3 From eab76694dfbbd10fce74b8ac59bf523a96cf37fa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 8 Oct 2020 13:49:50 +0200 Subject: SimpleAlign: add multi_way_if flag in config --- data/stylish-haskell.yaml | 1 + lib/Language/Haskell/Stylish/Config.hs | 3 ++- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 30 +++++++++++----------- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 12 +++++++++ 4 files changed, 30 insertions(+), 16 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index e0a739c..9709184 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -94,6 +94,7 @@ steps: cases: true top_level_patterns: true records: true + multi_way_if: true # Import cleanup - imports: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 36688a5..682d7d7 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -208,7 +208,8 @@ parseSimpleAlign c o = SimpleAlign.step <*> (SimpleAlign.Config <$> withDef SimpleAlign.cCases "cases" <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records") + <*> withDef SimpleAlign.cRecords "records" + <*> withDef SimpleAlign.cMultiWayIf "multi_way_if") where withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index e03f665..523a6fb 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , defaultConfig @@ -28,6 +29,7 @@ data Config = Config { cCases :: !Bool , cTopLevelPatterns :: !Bool , cRecords :: !Bool + , cMultiWayIf :: !Bool } deriving (Show) @@ -37,6 +39,7 @@ defaultConfig = Config { cCases = True , cTopLevelPatterns = True , cRecords = True + , cMultiWayIf = True } @@ -136,21 +139,18 @@ matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable - :: Config - -> Hs.LHsExpr Hs.GhcPs + :: Hs.LHsExpr Hs.GhcPs -> [Alignable S.RealSrcSpan] -multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = - fromMaybe [] $ traverse (grhsToAlignable conf) grhss -multiWayIfToAlignable _conf _ = [] +multiWayIfToAlignable (S.L _ (Hs.HsMultiIf _ grhss)) = + fromMaybe [] $ traverse grhsToAlignable grhss +multiWayIfToAlignable _ = [] -------------------------------------------------------------------------------- grhsToAlignable - :: Config - -> S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) -grhsToAlignable conf (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do - guard $ cCases conf +grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do let guardsLocs = map S.getLoc guards bodyLoc = S.getLoc body left = foldl1' S.combineSrcSpans guardsLocs @@ -163,13 +163,13 @@ grhsToAlignable conf (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable _conf (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x -grhsToAlignable _conf (S.L _ _) = Nothing +grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls module' -> +step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> let changes :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) -> (a -> [Alignable S.RealSrcSpan]) @@ -179,7 +179,7 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> configured :: [Change String] configured = concat $ - [changes records recordToAlignable | cRecords config] ++ + [changes records recordToAlignable | cRecords ] ++ [changes everything (matchGroupToAlignable config)] ++ - [changes everything (multiWayIfToAlignable config)] in + [changes everything multiWayIfToAlignable | cMultiWayIf] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 5b502d1..827022c 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -32,6 +32,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 11" case11 , testCase "case 12" case12 , testCase "case 13" case13 + , testCase "case 13b" case13b ] @@ -213,3 +214,14 @@ case13 = assertSnippet (step Nothing defaultConfig) , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] + +case13b :: Assertion +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] -- cgit v1.2.3 From 9f1e714f3d5ebee208a25fe8adaf89c34de5b04b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 8 Oct 2020 14:34:34 +0200 Subject: Add new option for aligning groups of adjacent items Co-authored-by: 1computer1 --- .gitignore | 1 + data/stylish-haskell.yaml | 15 ++-- lib/Language/Haskell/Stylish/Config.hs | 32 +++++--- lib/Language/Haskell/Stylish/GHC.hs | 40 ++++----- lib/Language/Haskell/Stylish/Module.hs | 30 +++---- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 95 +++++++++++++--------- tests/Language/Haskell/Stylish/Config/Tests.hs | 29 ++++++- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 82 ++++++++++++++++++- 8 files changed, 230 insertions(+), 94 deletions(-) diff --git a/.gitignore b/.gitignore index 738ffe6..37d51d4 100644 --- a/.gitignore +++ b/.gitignore @@ -17,5 +17,6 @@ cabal-dev cabal.config cabal.sandbox.config cabal.sandbox.config +cabal.project.local dist /dist-newstyle/ diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 9709184..e756b16 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -89,12 +89,17 @@ steps: # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single - # line. All default to true. + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. - simple_align: - cases: true - top_level_patterns: true - records: true - multi_way_if: true + cases: always + top_level_patterns: always + records: always + multi_way_if: always # Import cleanup - imports: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 682d7d7..dde9d0d 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,10 +10,12 @@ module Language.Haskell.Stylish.Config , defaultConfigBytes , configFilePath , loadConfig + , parseConfig ) where -------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A @@ -43,8 +45,8 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports -import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash import qualified Language.Haskell.Stylish.Step.Tabs as Tabs @@ -74,7 +76,7 @@ data ExitCodeBehavior deriving (Eq) instance Show ExitCodeBehavior where - show NormalExitBehavior = "normal" + show NormalExitBehavior = "normal" show ErrorOnFormatExitBehavior = "error_on_format" -------------------------------------------------------------------------------- @@ -206,12 +208,22 @@ parseSimpleAlign :: Config -> A.Object -> A.Parser Step parseSimpleAlign c o = SimpleAlign.step <$> pure (configColumns c) <*> (SimpleAlign.Config - <$> withDef SimpleAlign.cCases "cases" - <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records" - <*> withDef SimpleAlign.cMultiWayIf "multi_way_if") + <$> parseAlign "cases" SimpleAlign.cCases + <*> parseAlign "top_level_patterns" SimpleAlign.cTopLevelPatterns + <*> parseAlign "records" SimpleAlign.cRecords + <*> parseAlign "multi_way_if" SimpleAlign.cMultiWayIf) where - withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) + parseAlign key f = + (o A..:? key >>= parseEnum aligns (f SimpleAlign.defaultConfig)) <|> + (boolToAlign <$> o A..: key) + aligns = + [ ("always", SimpleAlign.Always) + , ("adjacent", SimpleAlign.Adjacent) + , ("never", SimpleAlign.Never) + ] + boolToAlign True = SimpleAlign.Always + boolToAlign False = SimpleAlign.Never + -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step @@ -295,8 +307,8 @@ parseImports config o = fmap (Imports.step columns) $ Imports.Options parseListPadding = \case A.String "module_name" -> pure Imports.LPModuleName - A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) - v -> A.typeMismatch "'module_name' or >=1 number" v + A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) + v -> A.typeMismatch "'module_name' or >=1 number" v -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index ee2d59f..c99d4bf 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -6,6 +6,7 @@ module Language.Haskell.Stylish.GHC , dropBeforeLocated , dropBeforeAndAfter -- * Unsafe getters + , unsafeGetRealSrcSpan , getEndLineUnsafe , getStartLineUnsafe -- * Standard settings @@ -18,32 +19,33 @@ module Language.Haskell.Stylish.GHC ) where -------------------------------------------------------------------------------- -import Data.Function (on) +import Data.Function (on) -------------------------------------------------------------------------------- -import DynFlags (Settings(..), defaultDynFlags) -import qualified DynFlags as GHC -import FileSettings (FileSettings(..)) -import GHC.Fingerprint (fingerprint0) +import DynFlags (Settings (..), defaultDynFlags) +import qualified DynFlags as GHC +import FileSettings (FileSettings (..)) +import GHC.Fingerprint (fingerprint0) import GHC.Platform -import GHC.Version (cProjectVersion) -import GhcNameVersion (GhcNameVersion(..)) -import PlatformConstants (PlatformConstants(..)) -import SrcLoc (GenLocated(..), SrcSpan(..)) -import SrcLoc (Located, RealLocated) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -import ToolSettings (ToolSettings(..)) -import qualified Outputable as GHC +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion (..)) +import qualified Outputable as GHC +import PlatformConstants (PlatformConstants (..)) +import SrcLoc (GenLocated (..), Located, RealLocated, + RealSrcSpan, SrcSpan (..), srcSpanEndLine, + srcSpanStartLine) +import ToolSettings (ToolSettings (..)) + +unsafeGetRealSrcSpan :: Located a -> RealSrcSpan +unsafeGetRealSrcSpan = \case + (L (RealSrcSpan s) _) -> s + _ -> error "could not get source code location" getStartLineUnsafe :: Located a -> Int -getStartLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanStartLine s - _ -> error "could not get start line of block" +getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan getEndLineUnsafe :: Located a -> Int -getEndLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanEndLine s - _ -> error "could not get end line of block" +getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropAfterLocated loc xs = case loc of diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 2cc8f47..3dbebe0 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -24,6 +24,7 @@ module Language.Haskell.Stylish.Module , moduleComments , moduleLanguagePragmas , queryModule + , groupByLine -- * Imports , canMergeImport @@ -192,22 +193,21 @@ moduleImports m -- | Get groups of imports from module moduleImportGroups :: Module -> [NonEmpty (Located Import)] -moduleImportGroups = go [] Nothing . moduleImports +moduleImportGroups = groupByLine unsafeGetRealSrcSpan . moduleImports + +-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. +groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] +groupByLine f = go [] Nothing where - -- Run through all imports (assume they are sorted already in order of - -- appearance in the file) and group the ones that are on consecutive - -- lines. - go :: [Located Import] -> Maybe Int -> [Located Import] - -> [NonEmpty (Located Import)] - go acc _ [] = ne acc - go acc mbCurrentLine (imp : impRest) = - let - lStart = getStartLineUnsafe imp - lEnd = getEndLineUnsafe imp in - case mbCurrentLine of - Just lPrevEnd | lPrevEnd + 1 < lStart - -> ne acc ++ go [imp] (Just lEnd) impRest - _ -> go (acc ++ [imp]) (Just lEnd) impRest + go acc _ [] = ne acc + go acc mbCurrentLine (x:xs) = + let + lStart = GHC.srcSpanStartLine (f x) + lEnd = GHC.srcSpanEndLine (f x) in + case mbCurrentLine of + Just lPrevEnd | lPrevEnd + 1 < lStart + -> ne acc ++ go [x] (Just lEnd) xs + _ -> go (acc ++ [x]) (Just lEnd) xs ne [] = [] ne (x : xs) = [x :| xs] diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 523a6fb..f8aea50 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -3,14 +3,16 @@ {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) + , Align (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- -import Control.Monad (guard) -import Data.List (foldl', foldl1') +import Data.Either (partitionEithers) +import Data.Foldable (toList) +import Data.List (foldl', foldl1', sortOn) import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -26,22 +28,34 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Config = Config - { cCases :: !Bool - , cTopLevelPatterns :: !Bool - , cRecords :: !Bool - , cMultiWayIf :: !Bool + { cCases :: Align + , cTopLevelPatterns :: Align + , cRecords :: Align + , cMultiWayIf :: Align } deriving (Show) +data Align + = Always + | Adjacent + | Never + deriving (Eq, Show) --------------------------------------------------------------------------------- defaultConfig :: Config defaultConfig = Config - { cCases = True - , cTopLevelPatterns = True - , cRecords = True - , cMultiWayIf = True + { cCases = Always + , cTopLevelPatterns = Always + , cRecords = Always + , cMultiWayIf = Always } +groupAlign :: Align -> [Alignable S.RealSrcSpan] -> [[Alignable S.RealSrcSpan]] +groupAlign a xs = case a of + Never -> [] + Adjacent -> byLine . sortOn (S.srcSpanStartLine . aLeft) $ xs + Always -> [xs] + where + byLine = map toList . groupByLine aLeft + -------------------------------------------------------------------------------- type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] @@ -65,8 +79,8 @@ records modu = do -------------------------------------------------------------------------------- -recordToAlignable :: Record -> [Alignable S.RealSrcSpan] -recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable +recordToAlignable :: Config -> Record -> [[Alignable S.RealSrcSpan]] +recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- @@ -89,36 +103,36 @@ fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) - -> [Alignable S.RealSrcSpan] + -> [[Alignable S.RealSrcSpan]] matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x -matchGroupToAlignable conf (Hs.MG _ alts _) = - fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts) +matchGroupToAlignable conf (Hs.MG _ alts _) = cases' ++ patterns' + where + (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (S.unLoc alts) + cases' = groupAlign (cCases conf) cases + patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- matchToAlignable - :: Config - -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) - -> Maybe (Alignable S.RealSrcSpan) -matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Either (Alignable S.RealSrcSpan) (Alignable S.RealSrcSpan)) +matchToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do let patsLocs = map S.getLoc pats pat = last patsLocs guards = getGuards m guardsLocs = map S.getLoc guards left = foldl' S.combineSrcSpans pat guardsLocs - guard $ cCases conf body <- rhsBody grhss matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left rightPos <- toRealSrcSpan $ S.getLoc body - Just $ Alignable + Just . Left $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = rightPos , aRightLead = length "-> " } -matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do - guard $ cTopLevelPatterns conf +matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do body <- unguardedRhsBody grhss let patsLocs = map S.getLoc pats nameLoc = S.getLoc name @@ -127,23 +141,26 @@ matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _ matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left bodyPos <- toRealSrcSpan bodyLoc - Just $ Alignable + Just . Right $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing +matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable - :: Hs.LHsExpr Hs.GhcPs - -> [Alignable S.RealSrcSpan] -multiWayIfToAlignable (S.L _ (Hs.HsMultiIf _ grhss)) = - fromMaybe [] $ traverse grhsToAlignable grhss -multiWayIfToAlignable _ = [] + :: Config + -> Hs.LHsExpr Hs.GhcPs + -> [[Alignable S.RealSrcSpan]] +multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = + groupAlign (cMultiWayIf conf) as + where + as = fromMaybe [] $ traverse grhsToAlignable grhss +multiWayIfToAlignable _conf _ = [] -------------------------------------------------------------------------------- @@ -163,8 +180,8 @@ grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x -grhsToAlignable (S.L _ _) = Nothing +grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing -------------------------------------------------------------------------------- @@ -172,14 +189,14 @@ step :: Maybe Int -> Config -> Step step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> let changes :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) - -> (a -> [Alignable S.RealSrcSpan]) + -> (a -> [[Alignable S.RealSrcSpan]]) -> [Change String] - changes search toAlign = concat $ - map (align maxColumns) . map toAlign $ search (parsedModule module') + changes search toAlign = + (concatMap . concatMap) (align maxColumns) . map toAlign $ search (parsedModule module') configured :: [Change String] configured = concat $ - [changes records recordToAlignable | cRecords ] ++ + [changes records (recordToAlignable config)] ++ [changes everything (matchGroupToAlignable config)] ++ - [changes everything multiWayIfToAlignable | cMultiWayIf] in + [changes everything (multiWayIfToAlignable config)] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs index 73062ab..3af6249 100644 --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -4,11 +4,14 @@ module Language.Haskell.Stylish.Config.Tests -------------------------------------------------------------------------------- -import qualified Data.Set as Set +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Set as Set +import qualified Data.YAML.Aeson as Yaml import System.Directory -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert, (@?=)) -------------------------------------------------------------------------------- @@ -31,6 +34,8 @@ tests = testGroup "Language.Haskell.Stylish.Config" testSpecifiedColumns , testCase "Correctly read .stylish-haskell.yaml file with no max column number" testNoColumns + , testCase "Backwards-compatible align options" + testBoolSimpleAlign ] @@ -105,6 +110,22 @@ testNoColumns = expected = Nothing +-------------------------------------------------------------------------------- +testBoolSimpleAlign :: Assertion +testBoolSimpleAlign = do + Right val <- pure $ Yaml.decode1 $ BL8.pack config + Aeson.Success conf <- pure $ Aeson.parse parseConfig val + length (configSteps conf) @?= 1 + where + config = unlines + [ "steps:" + , " - simple_align:" + , " cases: true" + , " top_level_patterns: always" + , " records: false" + ] + + -- | Example cabal file borrowed from -- https://www.haskell.org/cabal/users-guide/developing-packages.html -- with some default-extensions added diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 827022c..e30f0ba 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -33,6 +33,10 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 12" case12 , testCase "case 13" case13 , testCase "case 13b" case13b + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 ] @@ -194,7 +198,7 @@ case11 = assertSnippet (step Nothing defaultConfig) -------------------------------------------------------------------------------- case12 :: Assertion -case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input +case12 = assertSnippet (step Nothing defaultConfig { cCases = Never }) input input where input = [ "case x of" @@ -216,7 +220,7 @@ case13 = assertSnippet (step Nothing defaultConfig) ] case13b :: Assertion -case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" @@ -225,3 +229,77 @@ case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] + + +-------------------------------------------------------------------------------- +case14 :: Assertion +case14 = assertSnippet (step (Just 80) defaultConfig { cCases = Adjacent }) + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + + +-------------------------------------------------------------------------------- +case15 :: Assertion +case15 = assertSnippet (step (Just 80) defaultConfig { cTopLevelPatterns = Adjacent }) + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + + +-------------------------------------------------------------------------------- +case16 :: Assertion +case16 = assertSnippet (step (Just 80) defaultConfig { cRecords = Adjacent }) + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case17 :: Assertion +case17 = assertSnippet (step Nothing defaultConfig { cMultiWayIf = Adjacent }) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] -- cgit v1.2.3 From 84770e33bb6286c163c3b2b10fa98d264f6672b8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 8 Oct 2020 14:47:59 +0200 Subject: Bump version to 0.12.2.0 --- CHANGELOG | 8 ++++++++ stylish-haskell.cabal | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 602ce10..8561b5c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,13 @@ # CHANGELOG +- 0.12.2.0 (2020-10-08) + * align: Add a new option for aligning only adjacent items (by 1Computer1) + * align: Add support for aligning MultiWayIf syntax (by 1Computer1) + * data: Fix some issues with record field padding + * module_header: Add separate_lists option + * imports: Respect separate_lists for (..) imports + * data: Make sorting deriving list optional (by Maxim Koltsov) + - 0.12.1.0 (2020-10-05) * Bump Cabal-version to 2.4 (by Łukasz Gołębiewski) * Fix "group" import sort with multi-line imports (by Maxim Koltsov) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 1ae914e..c0f8764 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: stylish-haskell -Version: 0.12.1.0 +Version: 0.12.2.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD-3-Clause -- cgit v1.2.3