diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-01-17 11:15:37 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-01-17 11:15:37 -0700 |
| commit | 3130faccf7c9a9a7697e246884e2b60fd4b1f9de (patch) | |
| tree | ab171724845fe928ef05692c27351be933228ec2 | |
| parent | fd8bfa2853825504c2dbc7678154ac8d56d47035 (diff) | |
| parent | 84770e33bb6286c163c3b2b10fa98d264f6672b8 (diff) | |
| download | stylish-haskell-3130faccf7c9a9a7697e246884e2b60fd4b1f9de.tar.gz | |
Merge tag 'v0.12.2.0'
v0.12.2.0
- 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)
45 files changed, 5786 insertions, 2003 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index e1e9020..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.6' - - 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..1aa2369 --- /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.2 + 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 }}-v3 + + - 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 @@ -17,5 +17,6 @@ cabal-dev cabal.config cabal.sandbox.config cabal.sandbox.config +cabal.project.local dist /dist-newstyle/ @@ -1,5 +1,60 @@ # 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) + +- 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 + +- 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 + - 0.11.0.0 (2020-02-24) * Disable record formatting by default * Allow more customization for record formatting (by Maxim Koltsov) 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 diff --git a/README.markdown b/README.markdown index 4402a56..02ca635 100644 --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,5 @@ ## stylish-haskell -<img src="./assets/Logo/SVG/RoundedLogo.svg" width="100px"> - ## Introduction A simple Haskell code prettifier. The goal is not to format all of the code in @@ -223,3 +221,7 @@ Contributors: - Leonid Onokhov - Michael Snoyman - Mikhail Glushenkov +- Beatrice Vergani +- Paweł Szulc +- Łukasz Gołębiewski +- Felix Mulder diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index d7de260..e756b16 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -15,6 +15,22 @@ 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 + # + # # See `separate_lists` for the `imports` step. + # separate_lists: 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,14 +58,48 @@ 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" -- "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 + # 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 - # 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 + cases: always + top_level_patterns: always + records: always + multi_way_if: always # Import cleanup - imports: @@ -101,6 +151,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 +258,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/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. '<nixpkgs>'. + 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/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..dde9d0d 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,16 +1,21 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Stylish.Config ( Extensions , Config (..) + , ExitCodeBehavior (..) , defaultConfigBytes , configFilePath , loadConfig + , parseConfig ) where -------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A @@ -41,6 +46,7 @@ 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.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 @@ -60,8 +66,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 +142,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 +154,10 @@ parseConfig (A.Object o) = do , ("lf", IO.LF) , ("crlf", IO.CRLF) ] + exitCodes = + [ ("normal", NormalExitBehavior) + , ("error_on_format", ErrorOnFormatExitBehavior) + ] parseConfig _ = mzero @@ -144,6 +165,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,27 +194,54 @@ 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 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 parseSimpleAlign c o = SimpleAlign.step <$> pure (configColumns c) <*> (SimpleAlign.Config - <$> withDef SimpleAlign.cCases "cases" - <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records") + <$> 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 -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) + <*> (o A..:? "sort_deriving" A..!= True) + <*> 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 +263,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 +290,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 +305,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..c99d4bf --- /dev/null +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -0,0 +1,103 @@ +{-# 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 + , unsafeGetRealSrcSpan + , 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 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 = srcSpanStartLine . unsafeGetRealSrcSpan + +getEndLineUnsafe :: Located a -> Int +getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan + +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..3dbebe0 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -0,0 +1,283 @@ +{-# 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 + , groupByLine + + -- * 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 = groupByLine unsafeGetRealSrcSpan . moduleImports + +-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. +groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] +groupByLine f = go [] Nothing + where + 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] + +-- | 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 "<unknown>" 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 "<interactive>" 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..a7ddf5e --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -0,0 +1,458 @@ +{-# 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 + , pad + + -- ** 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 + +-- | 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 = + 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..77d12a0 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,126 +1,546 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +module Language.Haskell.Stylish.Step.Data + ( Config(..) + , defaultConfig -module Language.Haskell.Stylish.Step.Data where + , Indent(..) + , MaxColumns(..) + , step + ) where -import Data.List (find, intercalate) -import Data.Maybe (fromMaybe, maybeToList) -import qualified Language.Haskell.Exts as H -import Language.Haskell.Exts.Comments +-------------------------------------------------------------------------------- +import Prelude hiding (init) + +-------------------------------------------------------------------------------- +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 (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 (GenLocated (..), Located, + RealLocated) + +-------------------------------------------------------------------------------- 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]@ + , cSortDeriving :: !Bool + -- ^ If true, will sort type classes in a @deriving@ list. + , cMaxColumns :: !MaxColumns } deriving (Show) -datas :: H.Module l -> [H.Decl l] -datas (H.Module _ _ _ _ decls) = decls -datas _ = [] - -type ChangeLine = Change String +-- | 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" (step' cfg) - -step' :: Config -> Lines -> Module -> Lines -step' cfg ls (module', allComments) = applyChanges changes ls +step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where - datas' = datas $ fmap linesFromSrcSpan module' - changes = datas' >>= maybeToList . changeDecl allComments cfg + changes :: Module -> [ChangeLine] + changes m = fmap (formatDataDecl cfg m) (dataDecls m) + + 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 + } + _ -> [] + +type ChangeLine = Change String -findCommentOnLine :: LineBlock -> [Comment] -> Maybe Comment -findCommentOnLine lb = find commentOnLine +formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine +formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = + change originalDeclBlock (const printedDecl) where - commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) = - blockStart lb == start && blockEnd lb == end + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropBeforeAndAfter ldecl + + 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 + & (if cSortDeriving then sortBy compareOutputable else id) + & 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 + bracePos <- getCurrentLineLength + putText "{" + let fieldPos = bracePos + 2 + 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 + pad fieldPos >> 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 + -- 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 + (Indent x, Indent y) -> newline >> spaces (x + y + 2) + (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 + (Indent x, Indent y) -> x + y + 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 + 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..b89d73f 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -1,61 +1,78 @@ -{-# 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 + + , printImport + ) 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 +92,7 @@ data ListAlign | WithModuleName | WithAlias | AfterAlias + | Repeat deriving (Eq, Show) data EmptyListAlign @@ -83,375 +101,385 @@ 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 separateLists) . 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 :: Bool -> IE GhcPs -> P () +printImport _ (IEVar _ name) = do + printIeWrappedName name +printImport _ (IEThingAbs _ name) = do + printIeWrappedName name +printImport separateLists (IEThingAll _ name) = do + printIeWrappedName name + when separateLists space + putText "(..)" +printImport _ (IEModuleContents _ (L _ m)) = do + putText "module" + space + putText (moduleNameString m) +printImport separateLists (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 @@ -28,19 +41,6 @@ data Style -------------------------------------------------------------------------------- -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' = [ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}" @@ -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..58752fe --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -0,0 +1,222 @@ +{-# 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 ((&)) +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 +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 +import qualified Language.Haskell.Stylish.Step.Imports as Imports + + +data Config = Config + { indent :: Int + , sort :: Bool + , separateLists :: Bool + } + +defaultConfig :: Config +defaultConfig = Config + { indent = 4 + , sort = True + , separateLists = 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 = pad (indent conf + 2) + + 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 () + + -- NOTE(jaspervdj): This code is almost the same as the import printing + -- in 'Imports' and should be merged. + printExport :: GHC.LIE GhcPs -> P () + printExport = Imports.printImport (separateLists conf) . unLoc diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 5e61123..f8aea50 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,128 +1,202 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) + , Align (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- -import Data.Data (Data) -import Data.List (foldl') -import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts as H +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 -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- data Config = Config - { cCases :: !Bool - , cTopLevelPatterns :: !Bool - , cRecords :: !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 + { 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 + -------------------------------------------------------------------------------- -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 :: Config -> Record -> [[Alignable S.RealSrcSpan]] +recordToAlignable conf = groupAlign (cRecords conf) . 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 _) = cases' ++ patterns' + where + (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (S.unLoc alts) + cases' = groupAlign (cCases conf) cases + patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- -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 + :: 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 + body <- rhsBody grhss + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + rightPos <- toRealSrcSpan $ S.getLoc body + Just . Left $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = rightPos + , aRightLead = length "-> " + } +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 + left = last (nameLoc : patsLocs) + bodyLoc = S.getLoc body + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just . Right $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos + , aRightLead = length "= " } +matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing + + +-------------------------------------------------------------------------------- +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 _ = [] + + +-------------------------------------------------------------------------------- +grhsToAlignable + :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable S.RealSrcSpan) +grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do + 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 (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' +step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> + let changes + :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) + -> (a -> [[Alignable S.RealSrcSpan]]) + -> [Change String] changes search toAlign = - [ change_ - | case_ <- search module'' - , aligns <- maybeToList (mapM toAlign case_) - , change_ <- align maxColumns aligns - ] + (concatMap . concatMap) (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 config)] ++ + [changes everything (matchGroupToAlignable config)] ++ + [changes everything (multiWayIfToAlignable 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..ff01dee 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 @@ -52,38 +52,17 @@ groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] groupPerLine = M.toList . M.fromListWith (++) . map (\((r, c), x) -> (r, [(c, x)])) - --------------------------------------------------------------------------------- -typeSigs :: H.Module H.SrcSpanInfo -> 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 - ] - - --------------------------------------------------------------------------------- -contexts :: H.Module H.SrcSpanInfo -> 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 +-- | 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] + , (funStart, _) <- infoPoints funLoc + , (_, typeEnd) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between funStart typeEnd sym ls ] - --------------------------------------------------------------------------------- -typeFuns :: H.Module H.SrcSpanInfo -> 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 - ] - - -------------------------------------------------------------------------------- -- | 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 @@ -110,11 +89,9 @@ 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 - perLine = sort $ groupPerLine $ - typeSigs module' ls ++ - contexts module' ls ++ - typeFuns module' ls + toReplace = [ "::", "=>", "->" ] + perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 9883f4b..1d35a03 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,22 +13,35 @@ module Language.Haskell.Stylish.Util , wrapMaybe , wrapRestMaybe + -- * Extra list functions , withHead , withInit , withTail , withLast + , flagEnds + + , toRealSrcSpan + + , traceOutputable + , traceOutputableM + + , 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 -------------------------------------------------------------------------------- @@ -36,18 +49,6 @@ 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 [] = [] + + +-------------------------------------------------------------------------------- +traceOutputable :: Outputable.Outputable a => String -> a -> b -> b +traceOutputable title x = + trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x)) + + +-------------------------------------------------------------------------------- +traceOutputableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () +traceOutputableM title x = traceOutputable 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/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; + } 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 @@ -1,9 +1,10 @@ -resolver: lts-14.20 -packages: -- '.' +resolver: lts-16.9 extra-deps: -- 'Cabal-3.0.0.0' -- 'haskell-src-exts-1.23.0' -- 'HsYAML-0.2.1.0' -- 'HsYAML-aeson-0.2.0.0' +- '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' +- 'HsYAML-0.2.1.0@rev:1' + +save-hackage-creds: false diff --git a/stack.yaml.lock b/stack.yaml.lock index bc43b4e..3b36748 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,36 +5,43 @@ packages: - completed: - hackage: Cabal-3.0.0.0@sha256:1ba37b8d80e89213b17db7b8b9ea0108da55ca65f8c0cbb7433881a284c5cf67,26027 + hackage: ghc-lib-parser-8.10.1.20200324@sha256:6a0b014e97f627dd9ca177f26f184e2f2ff713ec1271045334ccb56ac7bfdff3,9116 pantry-tree: - size: 71616 - sha256: 4f16f0a65304ab22f01cb7f6d25db2f15a168f4cefacde7864cb1e02eb3ea867 + size: 19497 + sha256: ba6d7c3a2c3517b1a1f25daa04446209137a38e39b35367ffb13bbb2a0a7be4e original: - hackage: Cabal-3.0.0.0 + hackage: ghc-lib-parser-8.10.1.20200324 - completed: - hackage: haskell-src-exts-1.23.0@sha256:1bb9f7e97d569e56973133cb075fdcc1bfd11f90d94b035b5cf44814bb39a73d,4541 + hackage: aeson-1.5.2.0@sha256:d00c7aa51969b2849550e4dee14c9ce188504d55ed8d7f734ce9f6976db452f6,6786 pantry-tree: - size: 97804 - sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 + size: 39758 + sha256: 992b01282d72e4db664289db69a846a4ec675379ca96824ba902a7541104d409 original: - hackage: haskell-src-exts-1.23.0 + hackage: aeson-1.5.2.0 - completed: - hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311 + hackage: Cabal-3.2.0.0@sha256:d0d7a1f405f25d0000f5ddef684838bc264842304fd4e7f80ca92b997b710874,27320 pantry-tree: - size: 1340 - sha256: 21f61bf9cad31674126b106071dd9b852e408796aeffc90eec1792f784107eff + size: 40963 + sha256: b122f2d76dc82a350d3986fa0cbc4ecf9c3bb4f9c598ccbfb3b2bfdde02f3698 original: - hackage: HsYAML-0.2.1.0 + hackage: Cabal-3.2.0.0 - completed: - hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791 + hackage: HsYAML-aeson-0.2.0.0@sha256:b58e8587d480f8c29e4cb4f61ad6ab5d74195d31340e6e8c317ac4d13b65c469,1861 pantry-tree: size: 234 - sha256: 67cc9ba17c79e71d3abdb465a3ee2825477856fff3b8b7d543cbbbefdae9a9d9 + 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-aeson-0.2.0.0 + hackage: HsYAML-0.2.1.0@rev:1 snapshots: - completed: - size: 524154 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/20.yaml - sha256: 2f5099f69ddb6abfe64400fe1e6a604e8e628f55e6837211cd70a81eb0a8fa4d - original: lts-14.20 + size: 532380 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/9.yaml + sha256: 14a7cec114424e4286adde73364438927a553ed248cc50f069a30a67e3ee1e69 + original: lts-16.9 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8e9dffd..c0f8764 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,15 +1,15 @@ +Cabal-version: 2.4 Name: stylish-haskell -Version: 0.11.0.0 +Version: 0.12.2.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 <m@jaspervdj.be> Maintainer: Jasper Van der Jeugt <m@jaspervdj.be> Copyright: 2012 Jasper Van der Jeugt Category: Language Build-type: Simple -Cabal-version: >= 1.8 Description: A Haskell code prettifier. For more information, see: @@ -24,13 +24,18 @@ 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 + 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 @@ -45,58 +50,67 @@ 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 Language.Haskell.Stylish.Verbose Paths_stylish_haskell + Autogen-modules: + 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, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, 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, - 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 - 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, - strict >= 0.3 && < 0.4, + strict >= 0.3 && < 0.5, 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, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, 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, 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 @@ -107,13 +121,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 @@ -132,21 +153,24 @@ 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, 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, + Cabal >= 2.4 && < 3.3, containers >= 0.3 && < 0.7, 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..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 @@ -153,6 +174,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 <b" ] testMagicHashRegression :: Assertion -testMagicHashRegression = assert $ isRight $ parseModule [] Nothing $ unlines +testMagicHashRegression = returnsRight $ parseModule [] Nothing $ unlines [ "xs = \"foo\"#|1#|'a'#|bar#|Nil" ] -------------------------------------------------------------------------------- -isRight :: Either a b -> 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..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, (@=?)) @@ -35,6 +37,39 @@ 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 + , testCase "case 55" case55 + , testCase "case 56" case56 + , testCase "case 57" case57 ] case00 :: Assertion @@ -165,7 +200,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 +208,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 +373,8 @@ case16 = expected @=? testStep (step indentIndentStyle) input , "" , "data Foo" , " = Foo" - , " { a :: Int -- ^ comment" + , " { a :: Int" + , " -- ^ comment" , " }" ] @@ -419,7 +460,70 @@ case20 = input @=? testStep (step indentIndentStyle) input ] case21 :: Assertion -case21 = expected @=? testStep (step sameSameStyle) input +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 = 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 = 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 where input = unlines [ "data Foo a" @@ -432,18 +536,21 @@ case21 = expected @=? testStep (step sameSameStyle) input ] expected = unlines - [ "data Foo a = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" + [ "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 +case25 :: Assertion +case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input where input = unlines [ "data Foo a" @@ -451,86 +558,736 @@ case22 = expected @=? testStep (step sameIndentStyle) input , " a2 :: String" , " -- ^ some haddock" , " }" - , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (Eq, Show)" , " deriving (ToJSON)" ] expected = unlines [ "data Foo a = Foo" - , " { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar" - , " { b :: a" - , " }" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] -case23 :: Assertion -case23 = expected @=? testStep (step indentSameStyle) input +case26 :: Assertion +case26 = expected @=? testStep (step indentIndentStyle) input where input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] + [ "module Herp where" + , "" + , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo" + ] expected = unlines - [ "data Foo a" - , " = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " }" + , " deriving (FromJSON) via Bla Foo" ] -case24 :: Assertion -case24 = expected @=? testStep (step indentIndentStyle) input +case27 :: Assertion +case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input where input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] + [ "module Herp where" + , "" + , "data Foo = Foo | Bar | Baz deriving (Eq, Show)" + ] expected = unlines - [ "data Foo a" - , " = Foo" - , " { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar" - , " { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" + [ "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)" + ] + +case55 :: Assertion +case55 = expected @=? testStep (step sameSameNoSortStyle) input + where + input = unlines + [ "data Foo = Foo deriving (Z, Y, X, Bar, Abcd)" ] + 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 +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 +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 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 +-- <https://github.com/jaspervdj/stylish-haskell/pull/293>. +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..6889db4 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -1,13 +1,14 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Imports.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, (@=?)) -------------------------------------------------------------------------------- @@ -15,7 +16,6 @@ import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util - -------------------------------------------------------------------------------- fromImportAlign :: ImportAlign -> Options fromImportAlign align = defaultOptions { importAlign = align } @@ -59,12 +59,15 @@ 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 + , testCase "case 29" case29 + , testCase "case 30" case30 ] -------------------------------------------------------------------------------- -input :: String -input = unlines +input :: Snippet +input = [ "module Herp where" , "" , "import qualified Data.Map as M" @@ -83,96 +86,88 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input - where - expected = unlines - [ "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 @=? testStep (step (Just 80) $ fromImportAlign Group) input - where - expected = unlines - [ "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 @=? testStep (step (Just 80) $ fromImportAlign None) input - where - expected = unlines - [ "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 @=? testStep (step (Just 80) $ fromImportAlign Global) input' - where - input' = - "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 = unlines - [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," - , " object, parseEither, typeMismatch, (.!=)," - , " (.:), (.:?), (.=))" - ] + ] + [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," + , " object, parseEither, typeMismatch, (.!=)," + , " (.:), (.:?), (.=))" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep (step (Just 80) $ fromImportAlign Group) input' +case05 = assertSnippet (step (Just 80) $ fromImportAlign Group) input' input' where - input' = "import Distribution.PackageDescription.Configuration " ++ - "(finalizePackageDescription)\n" + -- Putting this on a different line shouldn't really help. + 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' = unlines + input' = [ "import Bar.Qux" , "import Foo.Bar" ] @@ -180,442 +175,434 @@ case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input' - where - input' = unlines - [ "import Bar.Qux" - , "" - , "import qualified Foo.Bar" - ] - - expected = unlines - [ "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" + ] -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Inline Inherit (LPConstant 4) True False) input - where - expected = unlines - [ "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\"" - ] +case08 = + let + options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False + in + 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\"" + ] -------------------------------------------------------------------------------- case08b :: Assertion -case08b = expected - @=? testStep (step (Just 80) $ Options Global WithModuleName True Inline Inherit (LPConstant 4) True False) input - where - expected = unlines - ["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\"" - ] +case08b = + let + options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False + in + 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\"" + ] -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Multiline Inherit (LPConstant 4) True False) input - where - expected = unlines - [ "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\"" - ] +case09 = + let + options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False + in + 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\"" + ] -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected - @=? testStep (step (Just 40) $ Options Group WithAlias True Multiline Inherit (LPConstant 4) True False) input - where - expected = unlines - [ "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\"" - ] +case10 = + let + options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False + in + 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\"" + ] + -------------------------------------------------------------------------------- case11 :: Assertion -case11 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 4) True False) input - where - expected = unlines - [ "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\"" - ] +case11 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 4) True False + in + 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 = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 4) True False) input - where - expected = unlines - [ "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 = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False + in + 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\"" + ] -------------------------------------------------------------------------------- case12 :: Assertion -case12 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 2) True False) input' - where - input' = unlines - [ "import Data.List (map)" - ] - - expected = unlines - [ "import Data.List" - , " (map)" - ] +case12 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 2) True False + in + assertSnippet (step (Just 80) options) + [ "import Data.List (map)" + ] + [ "import Data.List" + , " (map)" + ] -------------------------------------------------------------------------------- case12b :: Assertion -case12b = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 2) True False) input' - where - input' = unlines - [ "import Data.List (map)" - ] - - expected = input' +case12b = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False + in + assertSnippet (step (Just 80) options) + ["import Data.List (map)"] + ["import Data.List (map)"] -------------------------------------------------------------------------------- case13 :: Assertion -case13 = expected - @=? testStep (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False) input' - where - input' = unlines - [ "import qualified Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail, (++))" - ] - - expected = unlines - [ "import qualified Data.List as List" - , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," - , " (++))" - ] - +case13 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False + in + 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 = expected - @=? testStep (step (Just 80) $ Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False) input' - where - input' = unlines - [ "import qualified Data.List as List (concat, foldl, foldr, head, init," - , " last, length, map, null, reverse, tail, (++))" - ] - - expected = unlines - [ "import qualified Data.List as List" - , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," - , " (++))" - ] +case13b = + let + options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False + in + 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," + , " (++))" + ] -------------------------------------------------------------------------------- case14 :: Assertion -case14 = expected - @=? testStep - (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False) expected - where - expected = unlines - [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" - ] +case14 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False + in + 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, (++))" + ] -------------------------------------------------------------------------------- case15 :: Assertion -case15 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' - where - expected = unlines - [ "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' = unlines - [ "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)" - ] +case15 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False + in + 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)" + ] -------------------------------------------------------------------------------- case16 :: Assertion -case16 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) False False) input' - where - expected = unlines - [ "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' = unlines - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Maybe (Maybe (Just, Nothing))" - , "" - , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" - ] +case16 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False + in + 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))" + ] -------------------------------------------------------------------------------- case17 :: Assertion -case17 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' - where - expected = unlines - [ "import Control.Applicative (Applicative (pure, (<*>)))" - , "" - , "import Data.Identity (Identity (Identity, runIdentity))" - ] - - input' = unlines - [ "import Control.Applicative (Applicative ((<*>),pure))" - , "" - , "import Data.Identity (Identity (runIdentity,Identity))" - ] +case17 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False + in + 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))" + ] -------------------------------------------------------------------------------- case18 :: Assertion -case18 = expected @=? testStep - (step (Just 40) $ Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False) input' - where - expected = unlines - ---------------------------------------- - [ "import Data.Foo as Foo (Bar, Baz, Foo)" - , "" - , "import Data.Identity" - , " (Identity (Identity, runIdentity))" - , "" - , "import Data.Acid as Acid" - , " ( closeAcidState" - , " , createCheckpoint" - , " , openLocalStateFrom" - , " )" - ] - - input' = unlines - [ "import Data.Foo as Foo (Bar, Baz, Foo)" - , "" - , "import Data.Identity (Identity (Identity, runIdentity))" - , "" - , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" - ] +case18 = + let + options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False + in + 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" + , " )" + ] -------------------------------------------------------------------------------- case19 :: Assertion -case19 = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input - where - expected = unlines - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - +case19 = + let + options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False + in + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding" + , " (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19b :: Assertion -case19b = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input - where - expected = unlines - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - +case19b = + let + options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False + in + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19c :: Assertion -case19c = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input - where - expected = unlines - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - +case19c = + let + options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False + in + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] case19d :: Assertion -case19d = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input - where - expected = unlines - ---------------------------------------- - [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" - , "" - , "import Data.List" - , " (foldl', intercalate," - , " intersperse)" - ] - +case19d = + let + options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False + in + assertSnippet (step (Just 40) options) case19input + ---------------------------------------- + [ "import Prelude ()" + , "import Prelude.Compat hiding" + , " (foldMap)" + , "" + , "import Data.List" + , " (foldl', intercalate," + , " intersperse)" + ] -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" @@ -625,191 +612,233 @@ case20 = expected -------------------------------------------------------------------------------- case21 :: Assertion -case21 = expected - @=? testStep (step (Just 80) defaultOptions) input' - where - expected = unlines - [ "{-# 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' = unlines - [ "{-# 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 - @=? testStep (step (Just 80) defaultOptions) input' - where - expected = unlines - [ "{-# LANGUAGE PackageImports #-}" - , "import A" - , "import \"blah\" A" - , "import \"foo\" A" - , "import qualified \"foo\" A as X" - , "import \"foo\" B (shortName, someLongName, someLongerName," - , " theLongestNameYet)" - ] - input' = unlines - [ "{-# 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)" + ] -------------------------------------------------------------------------------- case23 :: Assertion -case23 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False Inline Inherit (LPConstant 4) True True) input' - where - expected = unlines - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class ( Default (def) )" - , "" - , "import Data.Monoid ( (<>) )" - , "" - , "import Data.ALongName.Foo ( Boo, Foo," - , " Goo )" - ] - - input' = unlines - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Monoid ((<>) )" - , "" - , "import Data.ALongName.Foo (Foo, Goo, Boo)" - ] +case23 = + let + options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True + in + 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 )" + ] -------------------------------------------------------------------------------- case23b :: Assertion -case23b = expected - @=? testStep (step (Just 40) $ Options None WithModuleName False Inline Inherit (LPConstant 4) True True) input' - where - expected = unlines - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class" - , " ( Default (def) )" - , "" - , "import Data.Monoid ( (<>) )" - , "" - , "import Data.ALongName.Foo ( Boo, Foo," - , " Goo )" - ] - - input' = unlines - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.Monoid ((<>) )" - , "" - , "import Data.ALongName.Foo (Foo, Goo, Boo)" - ] +case23b = + let + options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True + in + 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 )" + ] -------------------------------------------------------------------------------- case24 :: Assertion -case24 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True) input' - where - expected = unlines - [ "import Data.Acid ( AcidState )" - , "import Data.Default.Class" - , " ( Default (def) )" - , "" - , "import Data.ALongName.Foo" - , " ( BooReallyLong, FooReallyLong," - , " GooReallyLong )" - ] - - input' = unlines - [ "import Data.Acid (AcidState)" - , "import Data.Default.Class (Default(def))" - , "" - , "import Data.ALongName.Foo (FooReallyLong, " ++ - "GooReallyLong, BooReallyLong)" - ] +case24 = + let + options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True + in + 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 )" + ] -------------------------------------------------------------------------------- case25 :: Assertion -case25 = expected - @=? testStep (step (Just 80) $ Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False) input' - where - expected = unlines - [ "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' = unlines - [ "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))" - ] +case25 = + let + options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False + in + 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 - @=? testStep (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' = unlines - [ "import Data.List" - ] - expected = unlines - [ "import Data.List" - ] -------------------------------------------------------------------------------- case27 :: Assertion -case27 = expected @=? testStep (step Nothing $ fromImportAlign Global) input - where - expected = unlines - [ "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 = 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 = assertSnippet (step Nothing $ fromImportAlign Group) + -- Check that "Group" mode recognizes groups with multi-line imports + [ "import Foo (foo)" + , "import BarBar ( bar" + , " , kek)" + , "import Abcd ()" + , "" + , "import A (A)" + ] + [ "import Abcd ()" + , "import BarBar (bar, kek)" + , "import Foo (foo)" + , "" + , "import A (A)" + ] + + +-------------------------------------------------------------------------------- +case30 :: Assertion +case30 = assertSnippet (step Nothing defaultOptions {separateLists = False}) + ["import Data.Monoid (Monoid (..))"] + ["import Data.Monoid (Monoid(..))"] 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..002be7c --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -0,0 +1,313 @@ +{-# 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 + , testCase "Repects separate_lists" ex17 + ] + +-------------------------------------------------------------------------------- +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" + ] + +ex17 :: Assertion +ex17 = assertSnippet (step defaultConfig {separateLists = False}) + [ "module Foo" + , " ( Bar (..)" + , " ) where" + ] + [ "module Foo" + , " ( Bar(..)" + , " ) where" + ] diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index a2a51fc..e30f0ba 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,74 @@ 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 + , testCase "case 13" case13 + , testCase "case 13b" case13b + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 ] -------------------------------------------------------------------------------- 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 +106,200 @@ 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 +case09 = assertSnippet (step Nothing defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "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 = Never }) input input where - input = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" + input = + [ "case x of" + , " Just y -> 1" + , " Nothing -> 2" ] - expected = unlines - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] + +-------------------------------------------------------------------------------- +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" + ] + +case13b :: Assertion +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | 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" + ] 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" + ] 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 \"<unknown>.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,14 +35,45 @@ 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 createTempDirectory :: String -> IO FilePath @@ -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 |