├── .ghci ├── cabal.project ├── Setup.hs ├── assets └── Logo │ ├── PNG │ ├── 1x │ │ ├── Recurso 4mdpi.png │ │ ├── Recurso 5mdpi.png │ │ └── Recurso 6mdpi.png │ ├── 2x │ │ ├── Recurso 4xhdpi.png │ │ ├── Recurso 5xhdpi.png │ │ └── Recurso 6xhdpi.png │ ├── 1.5x │ │ ├── Recurso 4hdpi.png │ │ ├── Recurso 5hdpi.png │ │ └── Recurso 6hdpi.png │ └── 3x │ │ ├── Recurso 4xxhdpi.png │ │ ├── Recurso 5xxhdpi.png │ │ └── Recurso 6xxhdpi.png │ └── SVG │ ├── PinkLogo.svg │ ├── WhiteLogo.svg │ └── RoundedLogo.svg ├── scripts ├── stylish-haskell.sh └── latest.sh ├── .gitignore ├── examples └── Bad.hs ├── lib └── Language │ └── Haskell │ ├── Stylish │ ├── Verbose.hs │ ├── Step.hs │ ├── Step │ │ ├── Tabs.hs │ │ ├── TrailingWhitespace.hs │ │ ├── UnicodeSyntax.hs │ │ ├── Squash.hs │ │ ├── SimpleAlign.hs │ │ ├── LanguagePragmas.hs │ │ └── ModuleHeader.hs │ ├── Config │ │ ├── Internal.hs │ │ └── Cabal.hs │ ├── Ordering.hs │ ├── Block.hs │ ├── Align.hs │ ├── GHC.hs │ ├── Parse.hs │ ├── Module.hs │ ├── Comments.hs │ ├── Editor.hs │ ├── Util.hs │ └── Printer.hs │ └── Stylish.hs ├── haskell-pkgs.nix ├── default.nix ├── shell.nix ├── doc ├── release.md └── stylish-haskell.1.adoc ├── tests ├── Language │ └── Haskell │ │ └── Stylish │ │ ├── Regressions.hs │ │ ├── Step │ │ ├── Tabs │ │ │ └── Tests.hs │ │ ├── TrailingWhitespace │ │ │ └── Tests.hs │ │ ├── UnicodeSyntax │ │ │ └── Tests.hs │ │ ├── Squash │ │ │ └── Tests.hs │ │ ├── LanguagePragmas │ │ │ └── Tests.hs │ │ ├── SimpleAlign │ │ │ └── Tests.hs │ │ └── Imports │ │ │ └── FelixTests.hs │ │ ├── Tests │ │ └── Util.hs │ │ ├── Tests.hs │ │ ├── Parse │ │ └── Tests.hs │ │ └── Config │ │ └── Tests.hs └── TestSuite.hs ├── .github └── workflows │ └── ci.yml ├── LICENSE ├── Makefile ├── stylish-haskell.cabal ├── src └── Main.hs └── README.markdown /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itests -idist/build/autogen 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | tests: true 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /assets/Logo/PNG/1x/Recurso 4mdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1x/Recurso 4mdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/1x/Recurso 5mdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1x/Recurso 5mdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/1x/Recurso 6mdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1x/Recurso 6mdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/2x/Recurso 4xhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/2x/Recurso 4xhdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/2x/Recurso 5xhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/2x/Recurso 5xhdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/2x/Recurso 6xhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/2x/Recurso 6xhdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/1.5x/Recurso 4hdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1.5x/Recurso 4hdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/1.5x/Recurso 5hdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1.5x/Recurso 5hdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/1.5x/Recurso 6hdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/1.5x/Recurso 6hdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/3x/Recurso 4xxhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/3x/Recurso 4xxhdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/3x/Recurso 5xxhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/3x/Recurso 5xxhdpi.png -------------------------------------------------------------------------------- /assets/Logo/PNG/3x/Recurso 6xxhdpi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell/stylish-haskell/HEAD/assets/Logo/PNG/3x/Recurso 6xxhdpi.png -------------------------------------------------------------------------------- /scripts/stylish-haskell.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Ported from https://github.com/ndmitchell/hlint/blob/master/misc/travis.sh 3 | 4 | curl -sL https://raw.github.com/haskell/stylish-haskell/master/scripts/latest.sh | sh -s -- stylish-haskell $* 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.chi 3 | *.chs.h 4 | *.dyn_hi 5 | *.dyn_o 6 | *.hi 7 | *.hp 8 | *.o 9 | *.prof 10 | .cabal-sandbox/ 11 | .cabal-sandbox/ 12 | .hpc 13 | .hsenv 14 | .stack-work 15 | .stack-work/ 16 | cabal-dev 17 | cabal.config 18 | cabal.sandbox.config 19 | cabal.sandbox.config 20 | cabal.project.local 21 | dist 22 | /dist-newstyle/ 23 | -------------------------------------------------------------------------------- /examples/Bad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, TemplateHaskell #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, 3 | ViewPatterns, 4 | ScopedTypeVariables #-} 5 | 6 | module Bad where 7 | 8 | import Control.Applicative ((<$>)) 9 | import System.Directory (doesFileExist) 10 | 11 | import qualified Data.Map as M 12 | import Data.Map ((!), keys, Map) 13 | 14 | data Point = Point 15 | { pointX, pointY :: Double 16 | , pointName :: String 17 | } deriving (Show) 18 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Verbose.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Verbose 3 | ( Verbose 4 | , makeVerbose 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import System.IO (hPutStrLn, stderr) 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | type Verbose = String -> IO () 14 | 15 | 16 | -------------------------------------------------------------------------------- 17 | makeVerbose :: Bool -> Verbose 18 | makeVerbose verbose 19 | | verbose = hPutStrLn stderr 20 | | otherwise = const $ return () 21 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Step 3 | ( Lines 4 | , Step (..) 5 | , makeStep 6 | ) where 7 | 8 | 9 | -------------------------------------------------------------------------------- 10 | import Language.Haskell.Stylish.Module 11 | 12 | -------------------------------------------------------------------------------- 13 | data Step = Step 14 | { stepName :: String 15 | , stepFilter :: Lines -> Module -> Lines 16 | } 17 | 18 | -------------------------------------------------------------------------------- 19 | makeStep :: String -> (Lines -> Module -> Lines) -> Step 20 | makeStep = Step 21 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/Tabs.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Step.Tabs 3 | ( step 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import Language.Haskell.Stylish.Step 9 | 10 | 11 | -------------------------------------------------------------------------------- 12 | removeTabs :: Int -> String -> String 13 | removeTabs spaces = concatMap removeTabs' 14 | where 15 | removeTabs' '\t' = replicate spaces ' ' 16 | removeTabs' x = [x] 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | step :: Int -> Step 21 | step spaces = makeStep "Tabs" $ \ls _ -> map (removeTabs spaces) ls 22 | -------------------------------------------------------------------------------- /assets/Logo/SVG/PinkLogo.svg: -------------------------------------------------------------------------------- 1 | Recurso 8 -------------------------------------------------------------------------------- /assets/Logo/SVG/WhiteLogo.svg: -------------------------------------------------------------------------------- 1 | Recurso 6 -------------------------------------------------------------------------------- /haskell-pkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | # Fetch the latest haskell.nix and import its default.nix 3 | haskellNix = import 4 | (builtins.fetchTarball { 5 | url = "https://github.com/input-output-hk/haskell.nix/archive/cc40a24585ccba274dc9a5af96d5506034e0d658.tar.gz"; 6 | }) 7 | { }; 8 | 9 | # haskell.nix provides access to the nixpkgs pins which are used by our CI, 10 | # hence you will be more likely to get cache hits when using these. 11 | # But you can also just use your own, e.g. ''. 12 | nixpkgsSrc = haskellNix.sources.nixpkgs-2111; 13 | 14 | # haskell.nix provides some arguments to be passed to nixpkgs, including some 15 | # patches and also the haskell.nix functionality itself as an overlay. 16 | nixpkgsArgs = haskellNix.nixpkgsArgs; 17 | 18 | # import nixpkgs with overlays 19 | in 20 | import nixpkgsSrc nixpkgsArgs 21 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import ./haskell-pkgs.nix 2 | , haskellCompiler ? "ghc8107" 3 | }: 4 | pkgs.haskell-nix.cabalProject { 5 | src = pkgs.haskell-nix.haskellLib.cleanGit { 6 | name = "stylish-haskell"; 7 | src = ./.; 8 | }; 9 | 10 | compiler-nix-name = haskellCompiler; 11 | 12 | # need to make Cabal reinstallable, otherwise Haskell.nix uses the 13 | # version of Cabal that ships with the compiler even when that would 14 | # violate the constraint in stylish-haskell.cabal 15 | # 16 | # (eg nix-build failed because it tried to use Cabal-3.2.1.0 while 17 | # stylish-haskell needs Cabal >= 3.4 && < 3.7) 18 | # 19 | # See haskell-nix issue #1337 for details: 20 | # https://github.com/input-output-hk/haskell.nix/issues/1337 21 | modules = [ 22 | ({ lib, ... }: { 23 | options.nonReinstallablePkgs = lib.mkOption { apply = lib.remove "Cabal"; }; 24 | }) 25 | ]; 26 | } 27 | -------------------------------------------------------------------------------- /scripts/latest.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Ported from https://raw.githubusercontent.com/ndmitchell/neil/master/misc/travis.sh 3 | 4 | set -e 5 | 6 | PACKAGE=stylish-haskell 7 | echo Downloading and running $PACKAGE... 8 | 9 | RELEASES=$(curl --silent https://github.com/haskell/$PACKAGE/releases) 10 | ASSETS_URL=https://github.com/haskell/stylish-haskell/releases/expanded_assets/$(echo $RELEASES | grep -o 'v[0-9]\+\.[0-9]\+\.[0-9]\+\.[0-9]\+' | head -n1) 11 | ASSETS=$(curl --silent $ASSETS_URL) 12 | URL=https://github.com/$(echo $ASSETS | grep -o '\"[^\"]*-linux-x86_64\.tar\.gz\"' | sed s/\"//g | head -n1) 13 | VERSION=$(echo $URL | sed -e 's/.*-\(v[\.0-9]\+-linux-x86_64\)\.tar\.gz/\1/') 14 | TEMP=$(mktemp --directory .$PACKAGE-XXXXX) 15 | 16 | cleanup(){ 17 | rm -r $TEMP 18 | } 19 | trap cleanup EXIT 20 | 21 | curl --progress-bar --location -o$TEMP/$PACKAGE.tar.gz $URL 22 | tar -xzf $TEMP/$PACKAGE.tar.gz -C$TEMP 23 | $TEMP/$PACKAGE-$VERSION/$PACKAGE $* 24 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import ./haskell-pkgs.nix }: 2 | let 3 | hsPkgs = import ./. { inherit pkgs; }; 4 | in 5 | hsPkgs.shellFor { 6 | # Include only the *local* packages of your project. 7 | # packages = ps: with ps; [ 8 | # ]; 9 | 10 | # Builds a Hoogle documentation index of all dependencies, 11 | # and provides a "hoogle" command to search the index. 12 | # withHoogle = true; 13 | 14 | # You might want some extra tools in the shell (optional). 15 | # Some common tools can be added with the `tools` argument 16 | tools = { 17 | cabal = "3.6.2.0"; 18 | hlint = "3.3.6"; 19 | haskell-language-server = "1.6.1.1"; 20 | }; 21 | # See overlays/tools.nix for more details 22 | 23 | # Some you may need to get some other way. 24 | buildInputs = [ 25 | pkgs.ghcid 26 | pkgs.nixpkgs-fmt 27 | pkgs.stylish-haskell 28 | ]; 29 | 30 | # Prevents cabal from choosing alternate plans, so that 31 | # *all* dependencies are provided by Nix. 32 | exactDeps = true; 33 | } 34 | -------------------------------------------------------------------------------- /doc/release.md: -------------------------------------------------------------------------------- 1 | # Release checklist 2 | 3 | 1. First check if we can build against against all the newest dependencies. If 4 | that's not the case, it's probably a good idea to first make a separate 5 | commit to bump the dependency upper bounds (and test it). 6 | 7 | 2. Write up the `CHANGELOG`. You can inspect the log of what changed by doing 8 | something like: 9 | 10 | git log A.B.C.D.. 11 | 12 | Where `A.B.C.D` is the old version. 13 | 14 | 3. Now figure out whether this is a minor or major version bump. Follow the 15 | [PVP](https://pvp.haskell.org/) guidelines. Assume the new version is 16 | `E.F.G.H`. 17 | 18 | 4. Create a commit with the message `Bump version to E.F.G.H`. This commit 19 | should only change two things: 20 | 21 | - The version number in the `.cabal` file 22 | - The top of the `CHANGELOG` 23 | 24 | 4. Create a tarball using `cabal sdist` and upload this to Hackage. If the 25 | upload succeeds, create an annotated git tag: 26 | 27 | git tag -am E.F.G.H{,} 28 | git push --tags 29 | -------------------------------------------------------------------------------- /assets/Logo/SVG/RoundedLogo.svg: -------------------------------------------------------------------------------- 1 | Recurso 7 -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Step.TrailingWhitespace 3 | ( step 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import Data.Char (isSpace) 9 | 10 | 11 | -------------------------------------------------------------------------------- 12 | import Language.Haskell.Stylish.Step 13 | 14 | 15 | -------------------------------------------------------------------------------- 16 | dropTrailingWhitespace :: String -> String 17 | dropTrailingWhitespace = reverse . dropWhile isSpace . reverse 18 | 19 | 20 | -------------------------------------------------------------------------------- 21 | step :: Step 22 | step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace' ls 23 | where 24 | dropTrailingWhitespace' l = case l of 25 | -- Preserve page breaks 26 | "\12" -> l 27 | _ -> dropTrailingWhitespace l 28 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Regressions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Language.Haskell.Stylish.Regressions 4 | ( tests 5 | ) where 6 | 7 | import Language.Haskell.Stylish.Step.Imports 8 | import Language.Haskell.Stylish.Tests.Util (assertSnippet) 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | tests :: Test 15 | tests = testGroup "Language.Haskell.Stylish.Regressions" 16 | [ testCase "case 00 (issue #198)" case00 17 | ] 18 | 19 | -- | Error parsing '(,) #198 20 | -- 21 | -- See https://github.com/haskell/stylish-haskell/issues/198 22 | case00 :: Assertion 23 | case00 = assertSnippet (step (Just 80) $ importStepConfig Global) input input 24 | where 25 | input = 26 | [ "{-# LANGUAGE TemplateHaskell #-}" 27 | , "" 28 | , "import Language.Haskell.TH.Syntax" 29 | , "" 30 | , "main = print $ showName '(,)" 31 | ] 32 | 33 | importStepConfig :: ImportAlign -> Options 34 | importStepConfig align = defaultOptions { importAlign = align } 35 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.Tabs.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.Tabs 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.Tabs.Tests" 22 | [ testCase "case 01" case01 23 | ] 24 | 25 | 26 | -------------------------------------------------------------------------------- 27 | case01 :: Assertion 28 | case01 = assertSnippet (step 4) 29 | [ "module Main" 30 | , "\t\twhere" 31 | , "data Foo" 32 | , "\t= Bar" 33 | , " | Qux" 34 | ] 35 | [ "module Main" 36 | , " where" 37 | , "data Foo" 38 | , " = Bar" 39 | , " | Qux" 40 | ] 41 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Config/Internal.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Config.Internal 3 | ( ConfigSearchStrategy (..) 4 | , ancestors 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Data.List (inits) 10 | import System.FilePath (joinPath, splitPath) 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | -- All ancestors of a dir (including that dir) 15 | ancestors :: FilePath -> [FilePath] 16 | ancestors = map joinPath . reverse . dropWhile null . inits . splitPath 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | data ConfigSearchStrategy 21 | = -- | Don't try to search, just use given config file 22 | UseConfig FilePath 23 | | -- | Search for @.stylish-haskell.yaml@ starting from given directory. 24 | -- If not found, try all ancestor directories, @$XDG_CONFIG\/stylish-haskell\/config.yaml@ and @$HOME\/.stylish-haskell.yaml@ in order. 25 | -- If no config is found, default built-in config will be used. 26 | SearchFromDirectory FilePath 27 | | -- | Like SearchFromDirectory, but using current working directory as a starting point 28 | SearchFromCurrentDirectory 29 | -------------------------------------------------------------------------------- /doc/stylish-haskell.1.adoc: -------------------------------------------------------------------------------- 1 | = stylish-haskell(1) 2 | 3 | == NAME 4 | 5 | stylish-haskell - simple Haskell code prettifier 6 | 7 | == SYNOPSIS 8 | 9 | *stylish-haskell* [_-c_|_--config=FILE_] [_-v|--verbose_] 10 | [_-i_|_--inplace_] [--no-utf8] [_FILES_]... 11 | 12 | *stylish-haskell* _-d_|_--defaults_ 13 | 14 | *stylish-haskell* _-?_|_--help_ 15 | 16 | *stylish-haskell* _--version_ 17 | 18 | == DESCRIPTION 19 | 20 | *stylish-haskell* performs automatic formatting on the Haskell code in 21 | the files passed on the command line or piped via STDIN. It outputs to 22 | STDOUT unless *-i* is specified. 23 | 24 | STDIN is assumed to be encoded UTF-8, unless the *--no-utf8* option is 25 | used. 26 | 27 | === OPTIONS 28 | 29 | *-c*, *--config=FILE*:: 30 | Override the default configuration file. 31 | 32 | *-v*, *--verbose*:: 33 | Turn on verbose output. 34 | 35 | *-i*, *--inplace*:: 36 | Prettify and overwrite the given files in place. 37 | 38 | *-d*, *--defaults*:: 39 | Dump default config and exit. 40 | 41 | *-?*, *--help*:: 42 | Output help text and exit. 43 | 44 | *--version*:: 45 | Output version information and exit. 46 | 47 | *--no-utf8*:: 48 | Don't assume that STDIN is encoded UTF-8, and don't force UTF-8 output. 49 | 50 | == AUTHOR 51 | 52 | This manual page was originally written by Sean Whitton 53 | <\spwhitton@spwhitton.name> for the Debian GNU/Linux system (but may be 54 | used by others). 55 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.TrailingWhitespace.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.TrailingWhitespace 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.TrailingWhitespace.Tests" 22 | [ testCase "case 01" case01 23 | ] 24 | 25 | 26 | -------------------------------------------------------------------------------- 27 | case01 :: Assertion 28 | case01 = assertSnippet step 29 | [ "module Main where" 30 | , " \t" 31 | , "data Foo = Bar | Qux\t " 32 | , "\12" -- page break 33 | , " \12" -- malformed page break 34 | ] 35 | [ "module Main where" 36 | , "" 37 | , "data Foo = Bar | Qux" 38 | , "\12" -- page break 39 | , "" 40 | ] 41 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: ['pull_request', 'push'] 4 | 5 | jobs: 6 | build: 7 | name: Build on ${{ matrix.os }} with GHC ${{ matrix.ghc }} 8 | runs-on: ${{ matrix.os }} 9 | strategy: 10 | matrix: 11 | os: [ubuntu-latest, macOS-latest] 12 | ghc: ["9.10", "9.12"] 13 | 14 | steps: 15 | - uses: actions/checkout@v4 16 | 17 | - uses: haskell-actions/setup@v2 18 | id: setup 19 | with: 20 | ghc-version: ${{ matrix.ghc }} 21 | 22 | - uses: actions/cache@v3 23 | with: 24 | path: ${{ steps.setup.outputs.cabal-store }} 25 | key: ${{ runner.os }}-${{ matrix.ghc }}-v2-${{ hashFiles('*.cabal') }} 26 | restore-keys: | 27 | ${{ runner.os }}-${{ matrix.ghc }}-v2- 28 | 29 | - run: make build 30 | - run: make test 31 | 32 | - if: startsWith(github.ref, 'refs/tags') && startsWith(matrix.ghc, '9.10') 33 | run: make artifact 34 | 35 | - uses: actions/upload-artifact@v4 36 | if: startsWith(github.ref, 'refs/tags') && startsWith(matrix.ghc, '9.10') 37 | with: 38 | path: artifacts/* 39 | name: artifacts-${{ runner.os }} 40 | 41 | release: 42 | name: Release 43 | needs: build 44 | runs-on: ubuntu-latest 45 | if: startsWith(github.ref, 'refs/tags') 46 | 47 | steps: 48 | - uses: actions/download-artifact@v4 49 | with: 50 | pattern: artifacts-* 51 | 52 | - run: ls -R 53 | - run: 'sha256sum artifacts-*/*' 54 | 55 | - uses: softprops/action-gh-release@v1 56 | env: 57 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 58 | with: 59 | files: 'artifacts-*/stylish-haskell-*' 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Jasper Van der Jeugt 2 | Copyright (c) 2016, 2018 Sean Whitton 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Jasper Van der Jeugt nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ARCH=$(shell uname -m) 2 | UNAME=$(shell uname | tr 'A-Z' 'a-z') 3 | 4 | STYLISH_BINARY=$(HOME)/.local/bin/stylish-haskell 5 | STYLISH_TAG?=v$(shell sed -n 's/^Version: *//p' *.cabal) 6 | STYLISH_PACKAGE=stylish-haskell-$(STYLISH_TAG)-$(UNAME)-$(ARCH) 7 | 8 | UPX_VERSION=3.94 9 | UPX_NAME=upx-$(UPX_VERSION)-amd64_$(UNAME) 10 | UPX_BINARY=$(HOME)/.local/bin/upx 11 | 12 | ifeq ($(UNAME), darwin) 13 | ARCHIVE=zip 14 | ARCHIVE_CREATE=zip -r 15 | ARCHIVE_EXTRACT=unzip 16 | else 17 | ARCHIVE=tar.gz 18 | ARCHIVE_CREATE=tar czf 19 | ARCHIVE_EXTRACT=tar xvzf 20 | endif 21 | 22 | ifeq ($(UNAME), darwin) 23 | COMPRESS_BIN_DEPS= 24 | COMPRESS_BIN=ls 25 | else 26 | COMPRESS_BIN_DEPS=$(UPX_BINARY) 27 | COMPRESS_BIN=upx 28 | endif 29 | 30 | # Default target. 31 | .PHONY: build 32 | build: $(STYLISH_BINARY) 33 | 34 | # When we want to do a release. 35 | .PHONY: artifact 36 | artifact: $(STYLISH_PACKAGE).$(ARCHIVE) 37 | mkdir -p artifacts 38 | cp $(STYLISH_PACKAGE).$(ARCHIVE) artifacts/ 39 | 40 | $(STYLISH_PACKAGE).$(ARCHIVE): $(STYLISH_BINARY) $(COMPRESS_BIN_DEPS) 41 | mkdir -p $(STYLISH_PACKAGE) 42 | cp $(STYLISH_BINARY) $(STYLISH_PACKAGE)/ 43 | $(COMPRESS_BIN) $(STYLISH_PACKAGE)/stylish-haskell 44 | cp README.markdown $(STYLISH_PACKAGE)/ 45 | cp CHANGELOG $(STYLISH_PACKAGE)/ 46 | cp LICENSE $(STYLISH_PACKAGE)/ 47 | $(ARCHIVE_CREATE) $(STYLISH_PACKAGE).$(ARCHIVE) $(STYLISH_PACKAGE) 48 | 49 | $(STYLISH_BINARY): 50 | cabal install --installdir="$(dir $(STYLISH_BINARY))" 51 | 52 | # UPX is used to compress the resulting binary. We currently don't use this on 53 | # Mac OS. 54 | $(UPX_BINARY): 55 | curl -Lo /tmp/$(UPX_NAME).tar.xz \ 56 | https://github.com/upx/upx/releases/download/v$(UPX_VERSION)/$(UPX_NAME).tar.xz 57 | cd /tmp && tar xf $(UPX_NAME).tar.xz 58 | mv /tmp/$(UPX_NAME)/upx $(UPX_BINARY) 59 | upx --version 60 | 61 | .PHONY: test 62 | test: 63 | cabal test 64 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.UnicodeSyntax.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.UnicodeSyntax 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" 22 | [ testCase "case 01" case01 23 | , testCase "case 02" case02 24 | , testCase "case 03" case03 25 | ] 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | case01 :: Assertion 30 | case01 = assertSnippet (step True "LANGUAGE") 31 | [ "sort :: Ord a => [a] -> [a]" 32 | , "sort _ = []" 33 | ] 34 | [ "{-# LANGUAGE UnicodeSyntax #-}" 35 | , "sort ∷ Ord a ⇒ [a] → [a]" 36 | , "sort _ = []" 37 | ] 38 | 39 | 40 | -------------------------------------------------------------------------------- 41 | case02 :: Assertion 42 | case02 = assertSnippet (step True "LaNgUaGe") 43 | [ "sort :: Ord a => [a] -> [a]" 44 | , "sort _ = []" 45 | ] 46 | [ "{-# LaNgUaGe UnicodeSyntax #-}" 47 | , "sort ∷ Ord a ⇒ [a] → [a]" 48 | , "sort _ = []" 49 | ] 50 | 51 | 52 | -------------------------------------------------------------------------------- 53 | case03 :: Assertion 54 | case03 = assertSnippet (step False "LANGUAGE") 55 | [ "x :: Int -> Int -> Int" 56 | , "x = undefined" 57 | ] 58 | [ "x ∷ Int → Int → Int" 59 | , "x = undefined" 60 | ] 61 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Main 3 | ( main 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import Test.Framework (defaultMain) 9 | 10 | 11 | -------------------------------------------------------------------------------- 12 | import qualified Language.Haskell.Stylish.Config.Tests 13 | import qualified Language.Haskell.Stylish.Parse.Tests 14 | import qualified Language.Haskell.Stylish.Step.Data.Tests 15 | import qualified Language.Haskell.Stylish.Step.Imports.Tests 16 | import qualified Language.Haskell.Stylish.Step.Imports.FelixTests 17 | import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests 18 | import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests 19 | import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests 20 | import qualified Language.Haskell.Stylish.Step.Squash.Tests 21 | import qualified Language.Haskell.Stylish.Step.Tabs.Tests 22 | import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests 23 | import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests 24 | import qualified Language.Haskell.Stylish.Tests 25 | import qualified Language.Haskell.Stylish.Regressions 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | main :: IO () 30 | main = defaultMain 31 | [ Language.Haskell.Stylish.Parse.Tests.tests 32 | , Language.Haskell.Stylish.Config.Tests.tests 33 | , Language.Haskell.Stylish.Step.Data.Tests.tests 34 | , Language.Haskell.Stylish.Step.Imports.Tests.tests 35 | , Language.Haskell.Stylish.Step.Imports.FelixTests.tests 36 | , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests 37 | , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests 38 | , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests 39 | , Language.Haskell.Stylish.Step.Squash.Tests.tests 40 | , Language.Haskell.Stylish.Step.Tabs.Tests.tests 41 | , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests 42 | , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests 43 | , Language.Haskell.Stylish.Tests.tests 44 | , Language.Haskell.Stylish.Regressions.tests 45 | ] 46 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Step.UnicodeSyntax 3 | ( step 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import qualified GHC.Hs as GHC 9 | import qualified GHC.Types.SrcLoc as GHC 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | import qualified Language.Haskell.Stylish.Editor as Editor 14 | import Language.Haskell.Stylish.Module 15 | import Language.Haskell.Stylish.Step 16 | import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) 17 | import Language.Haskell.Stylish.Util (everything) 18 | 19 | 20 | -------------------------------------------------------------------------------- 21 | hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits 22 | hsTyReplacements (GHC.HsFunTy _ arr _ _) 23 | | GHC.HsUnrestrictedArrow (GHC.EpUniTok epaLoc GHC.NormalSyntax) <- arr = 24 | Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→" 25 | hsTyReplacements (GHC.HsQualTy _ ctx _) 26 | | Just arrow <- GHC.ac_darrow . GHC.anns $ GHC.getLoc ctx 27 | , (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan loc _)) GHC.NormalSyntax) <- arrow = 28 | Editor.replaceRealSrcSpan loc "⇒" 29 | hsTyReplacements _ = mempty 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits 34 | hsSigReplacements (GHC.TypeSig ann _ _) 35 | | GHC.EpUniTok epaLoc _ <- GHC.asDcolon ann 36 | , GHC.EpaSpan (GHC.RealSrcSpan loc _) <- epaLoc = 37 | Editor.replaceRealSrcSpan loc "∷" 38 | hsSigReplacements _ = mempty 39 | 40 | 41 | -------------------------------------------------------------------------------- 42 | step :: Bool -> String -> Step 43 | step = (makeStep "UnicodeSyntax" .) . step' 44 | 45 | 46 | -------------------------------------------------------------------------------- 47 | step' :: Bool -> String -> Lines -> Module -> Lines 48 | step' alp lg ls modu = Editor.apply edits ls 49 | where 50 | edits = 51 | foldMap hsTyReplacements (everything modu) <> 52 | foldMap hsSigReplacements (everything modu) <> 53 | (if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty) 54 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Ordering.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader', 3 | -- and maybe more in the future. This module provides consistent sorting 4 | -- utilities. 5 | {-# LANGUAGE LambdaCase #-} 6 | module Language.Haskell.Stylish.Ordering 7 | ( compareImports 8 | , compareLIE 9 | , compareWrappedName 10 | , compareOutputableCI 11 | ) where 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Data.Char (isUpper, toLower) 16 | import Data.Function (on) 17 | import Data.Ord (comparing) 18 | import GHC.Hs 19 | import qualified GHC.Hs as GHC 20 | import GHC.Types.SrcLoc (unLoc) 21 | import GHC.Utils.Outputable (Outputable) 22 | import qualified GHC.Utils.Outputable as GHC 23 | import Language.Haskell.Stylish.GHC (showOutputable) 24 | 25 | 26 | -------------------------------------------------------------------------------- 27 | -- | Compare imports for sorting. Cannot easily be a lawful instance due to 28 | -- case insensitivity. 29 | compareImports 30 | :: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering 31 | compareImports i0 i1 = 32 | ideclName i0 `compareOutputableCI` ideclName i1 <> 33 | showOutputable (ideclPkgQual i0) `compare` 34 | showOutputable (ideclPkgQual i1) <> 35 | compareOutputableCI i0 i1 36 | 37 | 38 | -------------------------------------------------------------------------------- 39 | -- | NOTE: Can we get rid off this by adding a properly sorting newtype around 40 | -- 'RdrName'? 41 | compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering 42 | compareLIE = comparing $ ieKey . unLoc 43 | where 44 | -- | The implementation is a bit hacky to get proper sorting for input specs: 45 | -- constructors first, followed by functions, and then operators. 46 | ieKey :: IE GhcPs -> (Int, String) 47 | ieKey = \case 48 | IEVar _ n _ -> nameKey n 49 | IEThingAbs _ n _ -> nameKey n 50 | IEThingAll _ n _ -> nameKey n 51 | IEThingWith _ n _ _ _ -> nameKey n 52 | IEModuleContents _ n -> nameKey n 53 | _ -> (2, "") 54 | 55 | 56 | -------------------------------------------------------------------------------- 57 | compareWrappedName :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering 58 | compareWrappedName = comparing nameKey 59 | 60 | 61 | -------------------------------------------------------------------------------- 62 | nameKey :: Outputable name => name -> (Int, String) 63 | nameKey n = case showOutputable n of 64 | o@('(' : _) -> (2, o) 65 | o@(o0 : _) | isUpper o0 -> (0, o) 66 | o -> (1, o) 67 | 68 | 69 | -------------------------------------------------------------------------------- 70 | compareOutputableCI :: GHC.Outputable a => a -> a -> Ordering 71 | compareOutputableCI = compare `on` (map toLower . showOutputable) 72 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Block.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Block 3 | ( Block (..) 4 | , LineBlock 5 | , realSrcSpanToLineBlock 6 | , SpanBlock 7 | , blockLength 8 | , moveBlock 9 | , adjacent 10 | , merge 11 | , mergeAdjacent 12 | , overlapping 13 | , groupAdjacent 14 | ) where 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | import qualified Data.IntSet as IS 19 | import qualified GHC.Types.SrcLoc as GHC 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | -- | Indicates a line span 24 | data Block a = Block 25 | { blockStart :: Int 26 | , blockEnd :: Int 27 | } deriving (Eq, Ord, Show) 28 | 29 | 30 | -------------------------------------------------------------------------------- 31 | instance Semigroup (Block a) where 32 | (<>) = merge 33 | 34 | 35 | -------------------------------------------------------------------------------- 36 | type LineBlock = Block String 37 | 38 | 39 | -------------------------------------------------------------------------------- 40 | type SpanBlock = Block Char 41 | 42 | 43 | -------------------------------------------------------------------------------- 44 | realSrcSpanToLineBlock :: GHC.RealSrcSpan -> Block String 45 | realSrcSpanToLineBlock s = Block (GHC.srcSpanStartLine s) (GHC.srcSpanEndLine s) 46 | 47 | 48 | -------------------------------------------------------------------------------- 49 | blockLength :: Block a -> Int 50 | blockLength (Block start end) = end - start + 1 51 | 52 | 53 | -------------------------------------------------------------------------------- 54 | moveBlock :: Int -> Block a -> Block a 55 | moveBlock offset (Block start end) = Block (start + offset) (end + offset) 56 | 57 | 58 | -------------------------------------------------------------------------------- 59 | adjacent :: Block a -> Block a -> Bool 60 | adjacent b1 b2 = follows b1 b2 || follows b2 b1 61 | where 62 | follows (Block _ e1) (Block s2 _) = e1 == s2 || e1 + 1 == s2 63 | 64 | 65 | -------------------------------------------------------------------------------- 66 | merge :: Block a -> Block a -> Block a 67 | merge (Block s1 e1) (Block s2 e2) = Block (min s1 s2) (max e1 e2) 68 | 69 | 70 | -------------------------------------------------------------------------------- 71 | overlapping :: [Block a] -> Bool 72 | overlapping = go IS.empty 73 | where 74 | go _ [] = False 75 | go acc (b : bs) = 76 | let ints = [blockStart b .. blockEnd b] in 77 | if any (`IS.member` acc) ints 78 | then True 79 | else go (IS.union acc $ IS.fromList ints) bs 80 | 81 | 82 | -------------------------------------------------------------------------------- 83 | -- | Groups adjacent blocks into larger blocks 84 | groupAdjacent :: [(Block a, b)] 85 | -> [(Block a, [b])] 86 | groupAdjacent = foldr go [] 87 | where 88 | -- This code is ugly and not optimal, and no fucks were given. 89 | go (b1, x) gs = case break (adjacent b1 . fst) gs of 90 | (_, []) -> (b1, [x]) : gs 91 | (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) 92 | 93 | mergeAdjacent :: [Block a] -> [Block a] 94 | mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest 95 | mergeAdjacent (a : rest) = a : mergeAdjacent rest 96 | mergeAdjacent [] = [] 97 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/Squash/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.Squash.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.Squash 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.SimpleSquash.Tests" 22 | [ testCase "case 01" case01 23 | , testCase "case 02" case02 24 | , testCase "case 03" case03 25 | , testCase "case 04" case04 26 | , testCase "case 05" case05 27 | , testCase "case 06 (issue #355)" case06 28 | ] 29 | 30 | 31 | -------------------------------------------------------------------------------- 32 | case01 :: Assertion 33 | case01 = assertSnippet step 34 | [ "data Foo = Foo" 35 | , " { foo :: Int" 36 | , " , barqux :: String" 37 | , " } deriving (Show)" 38 | ] 39 | [ "data Foo = Foo" 40 | , " { foo :: Int" 41 | , " , barqux :: String" 42 | , " } deriving (Show)" 43 | ] 44 | 45 | 46 | -------------------------------------------------------------------------------- 47 | case02 :: Assertion 48 | case02 = assertSnippet step 49 | [ "data Foo = Foo" 50 | , " { fooqux" 51 | , " , bar :: String" 52 | , " } deriving (Show)" 53 | ] 54 | [ "data Foo = Foo" 55 | , " { fooqux" 56 | , " , bar :: String" 57 | , " } deriving (Show)" 58 | ] 59 | 60 | 61 | -------------------------------------------------------------------------------- 62 | case03 :: Assertion 63 | case03 = assertSnippet step 64 | [ "maybe y0 f mx =" 65 | , " case mx of" 66 | , " Nothing -> y0" 67 | , " Just x -> f x" 68 | ] 69 | [ "maybe y0 f mx =" 70 | , " case mx of" 71 | , " Nothing -> y0" 72 | , " Just x -> f x" 73 | ] 74 | 75 | 76 | -------------------------------------------------------------------------------- 77 | case04 :: Assertion 78 | case04 = assertSnippet step 79 | [ "maybe y0 f mx =" 80 | , " case mx of" 81 | , " Nothing ->" 82 | , " y0" 83 | , " Just x ->" 84 | , " f x" 85 | ] 86 | [ "maybe y0 f mx =" 87 | , " case mx of" 88 | , " Nothing ->" 89 | , " y0" 90 | , " Just x ->" 91 | , " f x" 92 | ] 93 | 94 | 95 | -------------------------------------------------------------------------------- 96 | case05 :: Assertion 97 | case05 = assertSnippet step 98 | [ "maybe y0 _ Nothing = y" 99 | , "maybe _ f (Just x) = f x" 100 | ] 101 | [ "maybe y0 _ Nothing = y" 102 | , "maybe _ f (Just x) = f x" 103 | ] 104 | 105 | 106 | -------------------------------------------------------------------------------- 107 | -- See 108 | case06 :: Assertion 109 | case06 = assertSnippet step 110 | [ "main = (\\x -> putStrLn x) \"Hello, World!\"" 111 | ] 112 | [ "main = (\\x -> putStrLn x) \"Hello, World!\"" 113 | ] 114 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/Squash.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PartialTypeSignatures #-} 4 | {-# LANGUAGE PatternGuards #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module Language.Haskell.Stylish.Step.Squash 8 | ( step 9 | ) where 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | import qualified GHC.Hs as GHC 14 | import qualified GHC.Types.SrcLoc as GHC 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | import qualified Language.Haskell.Stylish.Editor as Editor 19 | import Language.Haskell.Stylish.Step 20 | import Language.Haskell.Stylish.Util 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | -- | Removes anything between two RealSrcSpans, providing they are on the same 25 | -- line. 26 | squash :: GHC.RealSrcSpan -> GHC.RealSrcSpan -> Editor.Edits 27 | squash l r 28 | | GHC.srcSpanEndLine l /= GHC.srcSpanStartLine r = mempty 29 | | GHC.srcSpanEndCol l >= GHC.srcSpanStartCol r = mempty 30 | | otherwise = Editor.replace 31 | (GHC.srcSpanEndLine l) 32 | (GHC.srcSpanEndCol l) 33 | (GHC.srcSpanStartCol r) 34 | " " 35 | 36 | 37 | -------------------------------------------------------------------------------- 38 | squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits 39 | squashFieldDecl (GHC.ConDeclField ext names@(_ : _) type' _) 40 | | Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last names 41 | , Just sep <- fieldDeclSeparator ext 42 | , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA type' = 43 | squash left sep <> squash sep right 44 | squashFieldDecl _ = mempty 45 | 46 | 47 | -------------------------------------------------------------------------------- 48 | fieldDeclSeparator :: GHC.EpUniToken "::" "\8759" -> Maybe GHC.RealSrcSpan 49 | fieldDeclSeparator (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) _) = Just s 50 | fieldDeclSeparator _ = Nothing 51 | 52 | 53 | -------------------------------------------------------------------------------- 54 | squashMatch 55 | :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Editor.Edits 56 | squashMatch lmatch = case GHC.m_grhss match of 57 | GHC.GRHSs _ [lgrhs] _ 58 | | GHC.GRHS ext [] body <- GHC.unLoc lgrhs 59 | , Just left <- mbLeft 60 | , Just sep <- matchSeparator ext 61 | , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body -> 62 | squash left sep <> squash sep right 63 | _ -> mempty 64 | where 65 | match = GHC.unLoc lmatch 66 | mbLeft = case match of 67 | GHC.Match _ (GHC.FunRhs name _ _ _ ) (GHC.L _ []) _ -> 68 | GHC.srcSpanToRealSrcSpan $ GHC.getLocA name 69 | GHC.Match _ _ (GHC.L _ pats@(_ : _)) _ -> 70 | GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last pats 71 | _ -> Nothing 72 | 73 | 74 | -------------------------------------------------------------------------------- 75 | matchSeparator :: GHC.EpAnn GHC.GrhsAnn -> Maybe GHC.RealSrcSpan 76 | matchSeparator GHC.EpAnn {..} = case GHC.ga_sep anns of 77 | Left (GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan s _))) -> Just s 78 | Right (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) _) -> Just s 79 | _ -> Nothing 80 | 81 | -------------------------------------------------------------------------------- 82 | step :: Step 83 | step = makeStep "Squash" $ \ls module' -> 84 | let changes = 85 | foldMap squashFieldDecl (everything module') <> 86 | foldMap squashMatch (everything module') in 87 | Editor.apply changes ls 88 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Align.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | This module is useful for aligning things. 3 | module Language.Haskell.Stylish.Align 4 | ( Alignable (..) 5 | , align 6 | ) where 7 | 8 | 9 | -------------------------------------------------------------------------------- 10 | import Data.List (nub) 11 | import qualified GHC.Types.SrcLoc as GHC 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import qualified Language.Haskell.Stylish.Editor as Editor 16 | import Language.Haskell.Stylish.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | -- | This represent a single line which can be aligned. We have something on 21 | -- the left and the right side, e.g.: 22 | -- 23 | -- > [x] -> x + 1 24 | -- > ^^^^ ^^^^^ 25 | -- > LEFT RIGHT 26 | -- 27 | -- We also have the container which holds the entire line: 28 | -- 29 | -- > [x] -> x + 1 30 | -- > ^^^^^^^^^^^^^ 31 | -- > CONTAINER 32 | -- 33 | -- And then we have a "right lead" which is just represented by an 'Int', since 34 | -- @haskell-src-exts@ often does not allow us to access it. In the example this 35 | -- is: 36 | -- 37 | -- > [x] -> x + 1 38 | -- > ^^^ 39 | -- > RLEAD 40 | -- 41 | -- This info is enough to align a bunch of these lines. Users of this module 42 | -- should construct a list of 'Alignable's representing whatever they want to 43 | -- align, and then call 'align' on that. 44 | data Alignable a = Alignable 45 | { aContainer :: !a 46 | , aLeft :: !a 47 | , aRight :: !a 48 | -- | This is the minimal number of columns we need for the leading part not 49 | -- included in our right string. For example, for datatype alignment, this 50 | -- leading part is the string ":: " so we use 3. 51 | , aRightLead :: !Int 52 | } deriving (Show) 53 | 54 | -------------------------------------------------------------------------------- 55 | -- | Create changes that perform the alignment. 56 | 57 | align 58 | :: Maybe Int -- ^ Max columns 59 | -> [Alignable GHC.RealSrcSpan] -- ^ Alignables 60 | -> Editor.Edits -- ^ Changes performing the alignment 61 | align _ [] = mempty 62 | align maxColumns alignment 63 | -- Do not make an changes if we would go past the maximum number of columns 64 | | exceedsColumns (longestLeft + longestRight) = mempty 65 | | not (fixable alignment) = mempty 66 | | otherwise = foldMap align' alignment 67 | where 68 | exceedsColumns i = case maxColumns of 69 | Nothing -> False 70 | Just c -> i > c 71 | 72 | -- The longest thing in the left column 73 | longestLeft = maximum $ map (GHC.srcSpanEndCol . aLeft) alignment 74 | 75 | -- The longest thing in the right column 76 | longestRight = maximum 77 | [ GHC.srcSpanEndCol (aRight a) - GHC.srcSpanStartCol (aRight a) 78 | + aRightLead a 79 | | a <- alignment 80 | ] 81 | 82 | align' a = Editor.changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str -> 83 | let column = GHC.srcSpanEndCol $ aLeft a 84 | (pre, post) = splitAt column str 85 | in [padRight longestLeft (trimRight pre) ++ trimLeft post] 86 | 87 | -------------------------------------------------------------------------------- 88 | -- | Checks that all the alignables appear on a single line, and that they do 89 | -- not overlap. 90 | 91 | fixable :: [Alignable GHC.RealSrcSpan] -> Bool 92 | fixable [] = False 93 | fixable [_] = False 94 | fixable fields = all singleLine containers && nonOverlapping containers 95 | where 96 | containers = map aContainer fields 97 | singleLine s = GHC.srcSpanStartLine s == GHC.srcSpanEndLine s 98 | nonOverlapping ss = length ss == length (nub $ map GHC.srcSpanStartLine ss) 99 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/GHC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# OPTIONS_GHC -Wno-missing-fields #-} 4 | -- | Utility functions for working with the GHC AST 5 | module Language.Haskell.Stylish.GHC 6 | ( dropAfterLocated 7 | , dropBeforeLocated 8 | , dropBeforeAndAfter 9 | -- * Unsafe getters 10 | , unsafeGetRealSrcSpan 11 | , getEndLineUnsafe 12 | , getStartLineUnsafe 13 | -- * Standard settings 14 | , baseDynFlags 15 | -- * Outputable operators 16 | , showOutputable 17 | 18 | -- * Deconstruction 19 | , getConDecls 20 | , epAnnComments 21 | , deepAnnComments 22 | ) where 23 | 24 | -------------------------------------------------------------------------------- 25 | import Data.Generics (Data, 26 | Typeable, 27 | everything, 28 | mkQ) 29 | import Data.List (sortOn) 30 | import qualified GHC.Driver.Ppr as GHC (showPpr) 31 | import GHC.Driver.Session (defaultDynFlags) 32 | import qualified GHC.Driver.Session as GHC 33 | import qualified GHC.Hs as GHC 34 | import GHC.Types.SrcLoc (GenLocated (..), 35 | Located, 36 | RealLocated, 37 | RealSrcSpan, 38 | SrcSpan (..), 39 | srcSpanEndLine, 40 | srcSpanStartLine) 41 | import qualified GHC.Types.SrcLoc as GHC 42 | import qualified GHC.Utils.Outputable as GHC 43 | import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx 44 | 45 | unsafeGetRealSrcSpan :: Located a -> RealSrcSpan 46 | unsafeGetRealSrcSpan = \case 47 | (L (RealSrcSpan s _) _) -> s 48 | _ -> error "could not get source code location" 49 | 50 | getStartLineUnsafe :: Located a -> Int 51 | getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan 52 | 53 | getEndLineUnsafe :: Located a -> Int 54 | getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan 55 | 56 | dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] 57 | dropAfterLocated loc xs = case loc of 58 | Just (L (RealSrcSpan rloc _) _) -> 59 | filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs 60 | _ -> xs 61 | 62 | dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] 63 | dropBeforeLocated loc xs = case loc of 64 | Just (L (RealSrcSpan rloc _) _) -> 65 | filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs 66 | _ -> xs 67 | 68 | dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b] 69 | dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc) 70 | 71 | baseDynFlags :: GHC.DynFlags 72 | baseDynFlags = defaultDynFlags GHCEx.fakeSettings 73 | 74 | getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs] 75 | getConDecls d@GHC.HsDataDefn {} = case GHC.dd_cons d of 76 | GHC.NewTypeCon con -> [con] 77 | GHC.DataTypeCons _ cons -> cons 78 | 79 | showOutputable :: GHC.Outputable a => a -> String 80 | showOutputable = GHC.showPpr baseDynFlags 81 | 82 | epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment] 83 | epAnnComments GHC.EpAnn {..} = priorAndFollowing comments 84 | 85 | deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment] 86 | deepAnnComments = everything (++) (mkQ [] priorAndFollowing) 87 | 88 | priorAndFollowing :: GHC.EpAnnComments -> [GHC.LEpaComment] 89 | priorAndFollowing = sortOn (GHC.epaLocationRealSrcSpan . GHC.getLoc) . \case 90 | GHC.EpaComments {..} -> priorComments 91 | GHC.EpaCommentsBalanced {..} -> priorComments ++ followingComments 92 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Language.Haskell.Stylish.Tests.Util 4 | ( dumpAst 5 | , dumpModule 6 | , Snippet (..) 7 | , assertSnippet 8 | , withTestDirTree 9 | ) where 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | import Control.Exception (bracket, try) 14 | import Data.Data (Data (..)) 15 | import GHC.Exts (IsList (..)) 16 | import GHC.Hs.Dump (BlankEpAnnotations (..), 17 | BlankSrcSpan (..), 18 | showAstData) 19 | import System.Directory (createDirectory, 20 | getCurrentDirectory, 21 | getTemporaryDirectory, 22 | removeDirectoryRecursive, 23 | setCurrentDirectory) 24 | import System.FilePath (()) 25 | import System.IO.Error (isAlreadyExistsError) 26 | import System.Random (randomIO) 27 | import Test.HUnit (Assertion, (@=?)) 28 | 29 | -------------------------------------------------------------------------------- 30 | import Language.Haskell.Stylish.GHC (showOutputable) 31 | import Language.Haskell.Stylish.Module (Module) 32 | import Language.Haskell.Stylish.Parse 33 | import Language.Haskell.Stylish.Step 34 | 35 | -------------------------------------------------------------------------------- 36 | -- | Takes a Haskell source as an argument and parse it into a Module. 37 | -- Extract function selects element from that Module record and returns 38 | -- its String representation. 39 | -- 40 | -- This function should be used when trying to understand how particular 41 | -- Haskell code will be represented by ghc-parser's AST 42 | dumpAst :: Data a => (Module -> a) -> String -> String 43 | dumpAst extract str = 44 | let Right(theModule) = parseModule [] Nothing str 45 | ast = extract theModule 46 | sdoc = showAstData BlankSrcSpan BlankEpAnnotations ast 47 | in showOutputable sdoc 48 | 49 | dumpModule :: String -> String 50 | dumpModule = dumpAst id 51 | 52 | -------------------------------------------------------------------------------- 53 | testStep :: Step -> String -> String 54 | testStep s str = case s of 55 | Step _ step -> 56 | case parseModule [] Nothing str of 57 | Left err -> error err 58 | Right module' -> unlines $ step ls module' 59 | where 60 | ls = lines str 61 | 62 | 63 | -------------------------------------------------------------------------------- 64 | -- | 'Lines' that show as a normal string. 65 | newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) 66 | 67 | -- Prefix with one newline since so HUnit will use a newline after `got: ` or 68 | -- `expected: `. 69 | instance Show Snippet where show = unlines . ("" :) . unSnippet 70 | 71 | instance IsList Snippet where 72 | type Item Snippet = String 73 | fromList = Snippet 74 | toList = unSnippet 75 | 76 | 77 | -------------------------------------------------------------------------------- 78 | testSnippet :: Step -> Snippet -> Snippet 79 | testSnippet s = Snippet . lines . testStep s . unlines . unSnippet 80 | 81 | 82 | -------------------------------------------------------------------------------- 83 | assertSnippet :: Step -> Snippet -> Snippet -> Assertion 84 | assertSnippet step input expected = expected @=? testSnippet step input 85 | 86 | 87 | -------------------------------------------------------------------------------- 88 | -- | Create a temporary directory with a randomised name built from the template 89 | -- provided 90 | createTempDirectory :: String -> IO FilePath 91 | createTempDirectory template = do 92 | tmpRootDir <- getTemporaryDirectory 93 | dirId <- randomIO :: IO Word 94 | findTempName tmpRootDir dirId 95 | where 96 | findTempName :: FilePath -> Word -> IO FilePath 97 | findTempName tmpRootDir x = do 98 | let dirpath = tmpRootDir template ++ show x 99 | r <- try $ createDirectory dirpath 100 | case r of 101 | Right _ -> return dirpath 102 | Left e | isAlreadyExistsError e -> findTempName tmpRootDir (x+1) 103 | | otherwise -> ioError e 104 | 105 | 106 | -------------------------------------------------------------------------------- 107 | -- | Perform an action inside a temporary directory tree and purge the tree 108 | -- afterwards 109 | withTestDirTree :: IO a -> IO a 110 | withTestDirTree action = bracket 111 | ((,) <$> getCurrentDirectory <*> createTempDirectory "stylish_haskell") 112 | (\(current, temp) -> 113 | setCurrentDirectory current *> 114 | removeDirectoryRecursive temp) 115 | (\(_, temp) -> setCurrentDirectory temp *> action) 116 | -------------------------------------------------------------------------------- /stylish-haskell.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: 2.4 2 | Name: stylish-haskell 3 | Version: 0.15.1.0 4 | Synopsis: Haskell code prettifier 5 | Homepage: https://github.com/haskell/stylish-haskell 6 | License: BSD-3-Clause 7 | License-file: LICENSE 8 | Author: Jasper Van der Jeugt 9 | Maintainer: Jasper Van der Jeugt 10 | Copyright: 2012 Jasper Van der Jeugt 11 | Category: Language 12 | Build-type: Simple 13 | 14 | Description: 15 | A Haskell code prettifier. For more information, see: 16 | 17 | . 18 | 19 | 20 | 21 | Extra-source-files: 22 | README.markdown, 23 | data/stylish-haskell.yaml 24 | 25 | Extra-doc-files: 26 | CHANGELOG 27 | 28 | Flag ghc-lib 29 | Default: True 30 | Manual: True 31 | Description: 32 | Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported 33 | 34 | Common depends 35 | Ghc-options: -Wall 36 | Default-language: Haskell2010 37 | 38 | Build-depends: 39 | aeson >= 0.6 && < 2.3, 40 | base >= 4.19 && < 5, 41 | bytestring >= 0.9 && < 0.13, 42 | Cabal >= 3.10 && < 4.0, 43 | containers >= 0.3 && < 0.9, 44 | directory >= 1.2.3 && < 1.4, 45 | filepath >= 1.1 && < 1.6, 46 | file-embed >= 0.0.10 && < 0.1, 47 | mtl >= 2.0 && < 2.4, 48 | regex-tdfa >= 1.3 && < 1.4, 49 | syb >= 0.3 && < 0.8, 50 | text >= 1.2 && < 2.2, 51 | HsYAML-aeson >=0.2.0 && < 0.3, 52 | HsYAML >=0.2.0 && < 0.3, 53 | 54 | if impl(ghc < 8.0) 55 | Build-depends: 56 | semigroups >= 0.18 && < 0.20 57 | 58 | -- Use GHC if the ghc-lib flag is not set 59 | -- and we have a new enough GHC. Note that 60 | -- this will only work if the user's 61 | -- compiler is of the matching major version! 62 | if !flag(ghc-lib) && impl(ghc >= 9.8) && impl(ghc < 9.13) 63 | Build-depends: 64 | ghc >= 9.12 && < 9.13, 65 | ghc-boot, 66 | ghc-boot-th 67 | else 68 | Build-depends: 69 | ghc-lib-parser >= 9.12 && < 9.13 70 | 71 | Build-depends: 72 | ghc-lib-parser-ex >= 9.12 && < 9.13 73 | 74 | Library 75 | Import: depends 76 | Hs-source-dirs: lib 77 | 78 | Exposed-modules: 79 | Language.Haskell.Stylish 80 | Language.Haskell.Stylish.Config 81 | Language.Haskell.Stylish.GHC 82 | Language.Haskell.Stylish.Module 83 | Language.Haskell.Stylish.Parse 84 | Language.Haskell.Stylish.Printer 85 | Language.Haskell.Stylish.Step 86 | Language.Haskell.Stylish.Step.Data 87 | Language.Haskell.Stylish.Step.Imports 88 | Language.Haskell.Stylish.Step.LanguagePragmas 89 | Language.Haskell.Stylish.Step.ModuleHeader 90 | Language.Haskell.Stylish.Step.SimpleAlign 91 | Language.Haskell.Stylish.Step.Squash 92 | Language.Haskell.Stylish.Step.Tabs 93 | Language.Haskell.Stylish.Step.TrailingWhitespace 94 | Language.Haskell.Stylish.Step.UnicodeSyntax 95 | 96 | Other-modules: 97 | Language.Haskell.Stylish.Align 98 | Language.Haskell.Stylish.Block 99 | Language.Haskell.Stylish.Comments 100 | Language.Haskell.Stylish.Config.Cabal 101 | Language.Haskell.Stylish.Config.Internal 102 | Language.Haskell.Stylish.Editor 103 | Language.Haskell.Stylish.Ordering 104 | Language.Haskell.Stylish.Util 105 | Language.Haskell.Stylish.Verbose 106 | Paths_stylish_haskell 107 | 108 | Autogen-modules: 109 | Paths_stylish_haskell 110 | 111 | Executable stylish-haskell 112 | Import: depends 113 | Hs-source-dirs: src 114 | Main-is: Main.hs 115 | 116 | Build-depends: 117 | stylish-haskell, 118 | strict >= 0.3 && < 0.6, 119 | optparse-applicative >= 0.12 && < 0.19 120 | 121 | Test-suite stylish-haskell-tests 122 | Import: depends 123 | Hs-source-dirs: tests 124 | Main-is: TestSuite.hs 125 | Type: exitcode-stdio-1.0 126 | 127 | Other-modules: 128 | Language.Haskell.Stylish.Config.Tests 129 | Language.Haskell.Stylish.Parse.Tests 130 | Language.Haskell.Stylish.Regressions 131 | Language.Haskell.Stylish.Step.Data.Tests 132 | Language.Haskell.Stylish.Step.Imports.FelixTests 133 | Language.Haskell.Stylish.Step.Imports.Tests 134 | Language.Haskell.Stylish.Step.LanguagePragmas.Tests 135 | Language.Haskell.Stylish.Step.ModuleHeader.Tests 136 | Language.Haskell.Stylish.Step.SimpleAlign.Tests 137 | Language.Haskell.Stylish.Step.Squash.Tests 138 | Language.Haskell.Stylish.Step.Tabs.Tests 139 | Language.Haskell.Stylish.Step.TrailingWhitespace.Tests 140 | Language.Haskell.Stylish.Step.UnicodeSyntax.Tests 141 | Language.Haskell.Stylish.Tests 142 | Language.Haskell.Stylish.Tests.Util 143 | 144 | Build-depends: 145 | stylish-haskell, 146 | HUnit >= 1.2 && < 1.7, 147 | random >= 1.1, 148 | test-framework >= 0.4 && < 0.9, 149 | test-framework-hunit >= 0.2 && < 0.4, 150 | 151 | Source-repository head 152 | Type: git 153 | Location: https://github.com/haskell/stylish-haskell 154 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE LambdaCase #-} 3 | module Language.Haskell.Stylish.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Data.List (isInfixOf, sort) 10 | import System.Directory (createDirectory) 11 | import System.FilePath (normalise, ()) 12 | import Test.Framework (Test, testGroup) 13 | import Test.Framework.Providers.HUnit (testCase) 14 | import Test.HUnit (Assertion, assertFailure, 15 | (@?=)) 16 | 17 | 18 | -------------------------------------------------------------------------------- 19 | import Language.Haskell.Stylish 20 | import Language.Haskell.Stylish.Tests.Util 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | tests :: Test 25 | tests = testGroup "Language.Haskell.Stylish.Tests" 26 | [ testCase "case 01" case01 27 | , testCase "case 02" case02 28 | , testCase "case 03" case03 29 | , testCase "case 04" case04 30 | , testCase "case 05" case05 31 | , testCase "case 06" case06 32 | , testCase "case 07" case07 33 | ] 34 | 35 | 36 | -------------------------------------------------------------------------------- 37 | case01 :: Assertion 38 | case01 = (@?= result) =<< format SearchFromCurrentDirectory Nothing input 39 | where 40 | input = "module Herp where\ndata Foo = Bar | Baz { baz :: Int }" 41 | result = Right $ lines input 42 | 43 | 44 | -------------------------------------------------------------------------------- 45 | case02 :: Assertion 46 | case02 = withTestDirTree $ do 47 | writeFile "test-config.yaml" $ unlines 48 | [ "steps:" 49 | , " - records:" 50 | , " equals: \"indent 2\"" 51 | , " first_field: \"indent 2\"" 52 | , " field_comment: 2" 53 | , " deriving: 2" 54 | , " via: \"indent 2\"" 55 | ] 56 | 57 | actual <- format (UseConfig "test-config.yaml") Nothing input 58 | actual @?= result 59 | where 60 | input = "module Herp where\ndata Foo = Bar | Baz { baz :: Int }" 61 | result = Right [ "module Herp where" 62 | , "data Foo" 63 | , " = Bar" 64 | , " | Baz" 65 | , " { baz :: Int" 66 | , " }" 67 | ] 68 | 69 | -------------------------------------------------------------------------------- 70 | case03 :: Assertion 71 | case03 = withTestDirTree $ do 72 | writeFile "test-config.yaml" $ unlines 73 | [ "steps:" 74 | , " - records:" 75 | , " equals: \"same_line\"" 76 | , " first_field: \"same_line\"" 77 | , " field_comment: 2" 78 | , " deriving: 2" 79 | , " via: \"indent 2\"" 80 | ] 81 | 82 | actual <- format (UseConfig "test-config.yaml") Nothing input 83 | actual @?= result 84 | where 85 | input = unlines [ "module Herp where" 86 | , "data Foo" 87 | , " = Bar" 88 | , " | Baz" 89 | , " { baz :: Int" 90 | , " }" 91 | ] 92 | result = Right [ "module Herp where" 93 | , "data Foo = Bar" 94 | , " | Baz { baz :: Int" 95 | , " }" 96 | ] 97 | 98 | 99 | -------------------------------------------------------------------------------- 100 | case04 :: Assertion 101 | case04 = format SearchFromCurrentDirectory (Just fileLocation) input >>= \case 102 | Right _ -> assertFailure "expected error" 103 | Left err 104 | | fileLocation `isInfixOf` err 105 | , needle `isInfixOf` err -> pure () 106 | | otherwise -> 107 | assertFailure $ "Unexpected error: " ++ show err 108 | where 109 | input = "module Herp" 110 | fileLocation = "directory/File.hs" 111 | needle = "possibly incorrect indentation or mismatched brackets" 112 | 113 | 114 | -------------------------------------------------------------------------------- 115 | -- | When providing current dir including folders and files. 116 | case05 :: Assertion 117 | case05 = withTestDirTree $ do 118 | createDirectory aDir >> writeFile c fileCont 119 | mapM_ (flip writeFile fileCont) fs 120 | result <- findHaskellFiles False input 121 | sort result @?= (sort $ map normalise expected) 122 | where 123 | input = c : fs 124 | fs = ["b.hs", "a.hs"] 125 | c = aDir "c.hs" 126 | aDir = "aDir" 127 | expected = ["a.hs", "b.hs", c] 128 | fileCont = "" 129 | 130 | 131 | -------------------------------------------------------------------------------- 132 | -- | When the input item is not file, do not recurse it. 133 | case06 :: Assertion 134 | case06 = withTestDirTree $ do 135 | mapM_ (flip writeFile "") input 136 | result <- findHaskellFiles False input 137 | result @?= expected 138 | where 139 | input = ["b.hs"] 140 | expected = map normalise input 141 | 142 | 143 | -------------------------------------------------------------------------------- 144 | -- | Empty input should result in empty output. 145 | case07 :: Assertion 146 | case07 = withTestDirTree $ do 147 | mapM_ (flip writeFile "") input 148 | result <- findHaskellFiles False input 149 | result @?= expected 150 | where 151 | input = [] 152 | expected = input 153 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Parse.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | module Language.Haskell.Stylish.Parse 3 | ( parseModule 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import Data.Char (toLower) 9 | import Data.List (foldl', 10 | stripPrefix) 11 | import Data.Maybe (catMaybes, 12 | fromMaybe, 13 | listToMaybe, 14 | mapMaybe) 15 | import Data.Traversable (for) 16 | import qualified GHC.Data.StringBuffer as GHC 17 | import qualified GHC.Driver.Config.Parser as GHC 18 | import GHC.Driver.Ppr as GHC 19 | import qualified GHC.Driver.Session as GHC 20 | import qualified GHC.LanguageExtensions.Type as LangExt 21 | import qualified GHC.Parser.Header as GHC 22 | import qualified GHC.Parser.Lexer as GHC 23 | import qualified GHC.Types.Error as GHC 24 | import qualified GHC.Types.SrcLoc as GHC 25 | import qualified GHC.Utils.Error as GHC 26 | import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx 27 | import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx 28 | 29 | 30 | -------------------------------------------------------------------------------- 31 | import Language.Haskell.Stylish.GHC 32 | import Language.Haskell.Stylish.Module 33 | 34 | 35 | -------------------------------------------------------------------------------- 36 | type Extensions = [String] 37 | 38 | 39 | -------------------------------------------------------------------------------- 40 | data ParseExtensionResult 41 | -- | Actual extension, and whether we want to turn it on or off. 42 | = ExtensionOk LangExt.Extension Bool 43 | -- | Failed to parse extension. 44 | | ExtensionError String 45 | -- | Other LANGUAGE things that aren't really extensions, like 'Safe'. 46 | | ExtensionIgnore 47 | 48 | 49 | -------------------------------------------------------------------------------- 50 | parseExtension :: String -> ParseExtensionResult 51 | parseExtension str 52 | | Just x <- GHCEx.readExtension str = ExtensionOk x True 53 | | 'N' : 'o' : str' <- str = case parseExtension str' of 54 | ExtensionOk x onOff -> ExtensionOk x (not onOff) 55 | result -> result 56 | | map toLower str `elem` ignores = ExtensionIgnore 57 | | otherwise = ExtensionError $ 58 | "Unknown extension: " ++ show str 59 | where 60 | ignores = ["unsafe", "trustworthy", "safe"] 61 | 62 | 63 | -------------------------------------------------------------------------------- 64 | -- | Filter out lines which use CPP macros 65 | unCpp :: String -> String 66 | unCpp = unlines . go False . lines 67 | where 68 | go _ [] = [] 69 | go isMultiline (x : xs) = 70 | let isCpp = isMultiline || listToMaybe x == Just '#' 71 | nextMultiline = isCpp && not (null x) && last x == '\\' 72 | in (if isCpp then "" else x) : go nextMultiline xs 73 | 74 | 75 | -------------------------------------------------------------------------------- 76 | -- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it 77 | -- because haskell-src-exts can't handle it. 78 | dropBom :: String -> String 79 | dropBom ('\xfeff' : str) = str 80 | dropBom str = str 81 | 82 | 83 | -------------------------------------------------------------------------------- 84 | -- | Abstraction over GHC lib's parsing 85 | parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module 86 | parseModule externalExts0 fp string = do 87 | -- Parse extensions. 88 | externalExts1 <- fmap catMaybes . for externalExts0 $ \str -> case parseExtension str of 89 | ExtensionError err -> Left err 90 | ExtensionIgnore -> pure Nothing 91 | ExtensionOk x onOff -> pure $ Just (x, onOff) 92 | 93 | -- Build first dynflags. 94 | let dynFlags0 = foldl' toggleExt baseDynFlags externalExts1 95 | 96 | -- Parse options from file 97 | let fileOptions = fmap GHC.unLoc $ snd $ GHC.getOptions (GHC.initParserOpts dynFlags0) 98 | (GHC.stringToStringBuffer string) 99 | (fromMaybe "-" fp) 100 | fileExtensions = mapMaybe (\str -> do 101 | str' <- stripPrefix "-X" str 102 | case parseExtension str' of 103 | ExtensionOk x onOff -> Just (x, onOff) 104 | _ -> Nothing) 105 | fileOptions 106 | 107 | -- Set further dynflags. 108 | let dynFlags1 = foldl' toggleExt dynFlags0 fileExtensions 109 | `GHC.gopt_set` GHC.Opt_KeepRawTokenStream 110 | 111 | -- Possibly strip CPP. 112 | let removeCpp s = if GHC.xopt LangExt.Cpp dynFlags1 then unCpp s else s 113 | input = removeCpp $ dropBom string 114 | 115 | -- Actual parse. 116 | case GHCEx.parseModule input dynFlags1 of 117 | GHC.POk _ m -> Right m 118 | GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 . GHC.pprMessages GHC.NoDiagnosticOpts . snd $ 119 | GHC.getPsMessages ps 120 | where 121 | withFileName x = maybe "" (<> ": ") fp <> x 122 | 123 | toggleExt dynFlags (ext, onOff) = foldl' 124 | toggleExt 125 | ((if onOff then GHC.xopt_set else GHC.xopt_unset) dynFlags ext) 126 | [(rhs, onOff') | (lhs, onOff', rhs) <- GHC.impliedXFlags, lhs == ext] 127 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Parse/Tests.hs: -------------------------------------------------------------------------------- 1 | module Language.Haskell.Stylish.Parse.Tests 2 | ( tests 3 | ) where 4 | 5 | 6 | -------------------------------------------------------------------------------- 7 | import Test.Framework (Test, testGroup) 8 | import Test.Framework.Providers.HUnit (testCase) 9 | import Test.HUnit (Assertion, assertFailure) 10 | import GHC.Stack (HasCallStack, withFrozenCallStack) 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | import Language.Haskell.Stylish.Parse 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | tests :: Test 19 | tests = testGroup "Language.Haskell.Stylish.Parse" 20 | [ testCase "UTF-8 Byte Order Mark" testBom 21 | , testCase "Extra extensions" testExtraExtensions 22 | , testCase "Multiline CPP" testMultilineCpp 23 | , testCase "Haskell2010 extension" testHaskell2010 24 | , testCase "Shebang" testShebang 25 | , testCase "ShebangExt" testShebangExt 26 | , testCase "ShebangDouble" testShebangDouble 27 | , testCase "GADTs extension" testGADTs 28 | , testCase "KindSignatures extension" testKindSignatures 29 | , testCase "StandalonDeriving extension" testStandaloneDeriving 30 | , testCase "UnicodeSyntax extension" testUnicodeSyntax 31 | , testCase "XmlSyntax regression" testXmlSyntaxRegression 32 | , testCase "MagicHash regression" testMagicHashRegression 33 | , testCase "Disabling extensions" testDisableExtensions 34 | , testCase "Safe extension" testSafeExtension 35 | ] 36 | 37 | -------------------------------------------------------------------------------- 38 | testShebangExt :: Assertion 39 | testShebangExt = returnsRight $ parseModule [] Nothing input 40 | where 41 | input = unlines 42 | [ "#!env runghc" 43 | , "{-# LANGUAGE CPP #-}" 44 | , "#define foo bar \\" 45 | , " qux" 46 | ] 47 | 48 | -------------------------------------------------------------------------------- 49 | testBom :: Assertion 50 | testBom = returnsRight $ parseModule [] Nothing input 51 | where 52 | input = unlines 53 | [ '\xfeff' : "foo :: Int" 54 | , "foo = 3" 55 | ] 56 | 57 | 58 | -------------------------------------------------------------------------------- 59 | testExtraExtensions :: Assertion 60 | testExtraExtensions = returnsRight $ 61 | parseModule ["TemplateHaskell"] Nothing "$(foo)" 62 | 63 | 64 | -------------------------------------------------------------------------------- 65 | testMultilineCpp :: Assertion 66 | testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines 67 | [ "{-# LANGUAGE CPP #-}" 68 | , "#define foo bar \\" 69 | , " qux" 70 | ] 71 | 72 | 73 | -------------------------------------------------------------------------------- 74 | testHaskell2010 :: Assertion 75 | testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines 76 | [ "{-# LANGUAGE Haskell2010 #-}" 77 | , "module X where" 78 | , "foo x | Just y <- x = y" 79 | ] 80 | 81 | 82 | -------------------------------------------------------------------------------- 83 | testShebang :: Assertion 84 | testShebang = returnsRight $ parseModule [] Nothing $ unlines 85 | [ "#!runhaskell" 86 | , "module Main where" 87 | , "main = return ()" 88 | ] 89 | 90 | -------------------------------------------------------------------------------- 91 | 92 | testShebangDouble :: Assertion 93 | testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines 94 | [ "#!nix-shell" 95 | , "#!nix-shell -i runhaskell -p haskellPackages.ghc" 96 | , "module Main where" 97 | , "main = return ()" 98 | ] 99 | 100 | -------------------------------------------------------------------------------- 101 | 102 | -- | These tests are for syntactic language extensions that should always be 103 | -- enabled for parsing, even when the pragma is absent. 104 | 105 | testGADTs :: Assertion 106 | testGADTs = returnsRight $ parseModule [] Nothing $ unlines 107 | [ "module Main where" 108 | , "data SafeList a b where" 109 | , " Nil :: SafeList a Empty" 110 | , " Cons:: a -> SafeList a b -> SafeList a NonEmpty" 111 | ] 112 | 113 | testKindSignatures :: Assertion 114 | testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines 115 | [ "module Main where" 116 | , "data D :: * -> * -> * where" 117 | , " D :: a -> b -> D a b" 118 | ] 119 | 120 | testStandaloneDeriving :: Assertion 121 | testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines 122 | [ "module Main where" 123 | , "deriving instance Show MyType" 124 | ] 125 | 126 | testUnicodeSyntax :: Assertion 127 | testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines 128 | [ "module Main where" 129 | , "monadic ∷ (Monad m) ⇒ m a → m a" 130 | , "monadic = id" 131 | ] 132 | 133 | testXmlSyntaxRegression :: Assertion 134 | testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines 135 | [ "smaller a b = a Show a => Either a b -> Assertion 159 | returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action 160 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | -------------------------------------------------------------------------------- 3 | module Language.Haskell.Stylish 4 | ( -- * Run 5 | runSteps 6 | -- * Steps 7 | , simpleAlign 8 | , imports 9 | , languagePragmas 10 | , tabs 11 | , trailingWhitespace 12 | , unicodeSyntax 13 | -- ** Helpers 14 | , findHaskellFiles 15 | , stepName 16 | -- * Config 17 | , module Language.Haskell.Stylish.Config 18 | -- * Misc 19 | , module Language.Haskell.Stylish.Verbose 20 | , version 21 | , format 22 | , ConfigSearchStrategy(..) 23 | , Lines 24 | , Step 25 | ) where 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | import Control.Monad (foldM) 30 | import System.Directory (doesDirectoryExist, 31 | doesFileExist, 32 | listDirectory) 33 | import System.FilePath (takeExtension, 34 | ()) 35 | 36 | -------------------------------------------------------------------------------- 37 | import Language.Haskell.Stylish.Config 38 | import Language.Haskell.Stylish.Parse 39 | import Language.Haskell.Stylish.Step 40 | import qualified Language.Haskell.Stylish.Step.Imports as Imports 41 | import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas 42 | import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign 43 | import qualified Language.Haskell.Stylish.Step.Tabs as Tabs 44 | import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace 45 | import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax 46 | import Language.Haskell.Stylish.Verbose 47 | import Paths_stylish_haskell (version) 48 | 49 | 50 | -------------------------------------------------------------------------------- 51 | simpleAlign :: Maybe Int -- ^ Columns 52 | -> SimpleAlign.Config 53 | -> Step 54 | simpleAlign = SimpleAlign.step 55 | 56 | 57 | -------------------------------------------------------------------------------- 58 | imports :: Maybe Int -- ^ columns 59 | -> Imports.Options 60 | -> Step 61 | imports = Imports.step 62 | 63 | 64 | -------------------------------------------------------------------------------- 65 | languagePragmas :: Maybe Int -- ^ columns 66 | -> LanguagePragmas.Style 67 | -> Bool -- ^ Pad to same length in vertical mode? 68 | -> Bool -- ^ remove redundant? 69 | -> String -- ^ language prefix 70 | -> Step 71 | languagePragmas = LanguagePragmas.step 72 | 73 | 74 | -------------------------------------------------------------------------------- 75 | tabs :: Int -- ^ number of spaces 76 | -> Step 77 | tabs = Tabs.step 78 | 79 | 80 | -------------------------------------------------------------------------------- 81 | trailingWhitespace :: Step 82 | trailingWhitespace = TrailingWhitespace.step 83 | 84 | 85 | -------------------------------------------------------------------------------- 86 | unicodeSyntax :: Bool -- ^ add language pragma? 87 | -> String -- ^ language prefix 88 | -> Step 89 | unicodeSyntax = UnicodeSyntax.step 90 | 91 | 92 | -------------------------------------------------------------------------------- 93 | runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines 94 | runStep exts mfp ls = \case 95 | Step _name step -> 96 | step ls <$> parseModule exts mfp (unlines ls) 97 | 98 | -------------------------------------------------------------------------------- 99 | runSteps :: 100 | Extensions 101 | -> Maybe FilePath 102 | -> [Step] 103 | -> Lines 104 | -> Either String Lines 105 | runSteps exts mfp steps ls = 106 | foldM (runStep exts mfp) ls steps 107 | 108 | 109 | -- | Formats given contents. 110 | format :: 111 | ConfigSearchStrategy 112 | -> Maybe FilePath 113 | -- ^ the location from which the contents to format were read. 114 | -- If provided, it's going to be printed out in the error message. 115 | -> String -- ^ the contents to format 116 | -> IO (Either String Lines) 117 | format configSearchStrategy maybeFilePath contents = do 118 | conf <- loadConfig (makeVerbose True) configSearchStrategy 119 | pure $ runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) $ lines contents 120 | 121 | 122 | -------------------------------------------------------------------------------- 123 | -- | Searches Haskell source files in any given folder recursively. 124 | findHaskellFiles :: Bool -> [FilePath] -> IO [FilePath] 125 | findHaskellFiles v fs = mapM (findFilesR v) fs >>= return . concat 126 | 127 | 128 | -------------------------------------------------------------------------------- 129 | findFilesR :: Bool -> FilePath -> IO [FilePath] 130 | findFilesR _ [] = return [] 131 | findFilesR v path = do 132 | doesFileExist path >>= \case 133 | True -> return [path] 134 | _ -> doesDirectoryExist path >>= \case 135 | True -> findFilesRecursive path >>= 136 | return . filter (\x -> takeExtension x == ".hs") 137 | False -> do 138 | makeVerbose v ("Input folder does not exists: " <> path) 139 | findFilesR v [] 140 | where 141 | findFilesRecursive :: FilePath -> IO [FilePath] 142 | findFilesRecursive = listDirectoryFiles findFilesRecursive 143 | 144 | listDirectoryFiles :: (FilePath -> IO [FilePath]) 145 | -> FilePath -> IO [FilePath] 146 | listDirectoryFiles go topdir = do 147 | ps <- listDirectory topdir >>= 148 | mapM (\x -> do 149 | let dir = topdir x 150 | doesDirectoryExist dir >>= \case 151 | True -> go dir 152 | False -> return [dir]) 153 | return $ concat ps 154 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TupleSections #-} 9 | module Language.Haskell.Stylish.Module 10 | ( -- * Data types 11 | Module 12 | , Comments (..) 13 | , Lines 14 | 15 | -- * Getters 16 | , moduleImportGroups 17 | , queryModule 18 | , groupByLine 19 | 20 | -- * Imports 21 | , canMergeImport 22 | , mergeModuleImport 23 | , importModuleName 24 | 25 | -- * Pragmas 26 | , moduleLanguagePragmas 27 | ) where 28 | 29 | 30 | -------------------------------------------------------------------------------- 31 | import Data.Char (toLower) 32 | import Data.Function (on) 33 | import Data.Generics (Typeable, everything, mkQ) 34 | import qualified Data.List as L 35 | import Data.List.NonEmpty (NonEmpty (..)) 36 | import Data.Maybe (fromMaybe, mapMaybe) 37 | import GHC.Hs (ImportDecl (..), 38 | ImportDeclQualifiedStyle (..)) 39 | import qualified GHC.Hs as GHC 40 | import GHC.Hs.Extension (GhcPs) 41 | import qualified GHC.Types.PkgQual as GHC 42 | import GHC.Types.SrcLoc (GenLocated (..), 43 | RealSrcSpan (..), unLoc) 44 | import qualified GHC.Types.SrcLoc as GHC 45 | 46 | 47 | -------------------------------------------------------------------------------- 48 | import Language.Haskell.Stylish.GHC 49 | 50 | 51 | -------------------------------------------------------------------------------- 52 | type Lines = [String] 53 | 54 | deriving instance Eq GHC.RawPkgQual 55 | 56 | -------------------------------------------------------------------------------- 57 | -- | Concrete module type 58 | type Module = GHC.Located (GHC.HsModule GHC.GhcPs) 59 | 60 | importModuleName :: ImportDecl GhcPs -> String 61 | importModuleName = GHC.moduleNameString . GHC.unLoc . GHC.ideclName 62 | 63 | -- | Returns true if the two import declarations can be merged 64 | canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool 65 | canMergeImport i0 i1 = and $ fmap (\f -> f i0 i1) 66 | [ (==) `on` unLoc . ideclName 67 | , (==) `on` ideclPkgQual 68 | , (==) `on` ideclSource 69 | , hasMergableQualified `on` ideclQualified 70 | , (==) `on` fmap unLoc . ideclAs 71 | , (==) `on` fmap fst . ideclImportList -- same 'hiding' flags 72 | ] 73 | where 74 | hasMergableQualified QualifiedPre QualifiedPost = True 75 | hasMergableQualified QualifiedPost QualifiedPre = True 76 | hasMergableQualified q0 q1 = q0 == q1 77 | 78 | -- | Comments associated with module 79 | newtype Comments = Comments [GHC.RealLocated GHC.EpaComment] 80 | 81 | -- | Get groups of imports from module 82 | moduleImportGroups :: Module -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)] 83 | moduleImportGroups = 84 | groupByLine (fromMaybe err . GHC.srcSpanToRealSrcSpan . GHC.getLocA) . 85 | GHC.hsmodImports . GHC.unLoc 86 | where 87 | err = error "moduleImportGroups: import without soure span" 88 | 89 | -- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. 90 | groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] 91 | groupByLine f = go [] Nothing 92 | where 93 | go acc _ [] = ne acc 94 | go acc mbCurrentLine (x:xs) = 95 | let 96 | lStart = GHC.srcSpanStartLine (f x) 97 | lEnd = GHC.srcSpanEndLine (f x) in 98 | case mbCurrentLine of 99 | Just lPrevEnd | lPrevEnd + 1 < lStart 100 | -> ne acc ++ go [x] (Just lEnd) xs 101 | _ -> go (acc ++ [x]) (Just lEnd) xs 102 | 103 | ne [] = [] 104 | ne (x : xs) = [x :| xs] 105 | 106 | -- | Merge two import declarations, keeping positions from the first 107 | -- 108 | -- As alluded, this highlights an issue with merging imports. The GHC 109 | -- annotation comments aren't attached to any particular AST node. This 110 | -- means that right now, we're manually reconstructing the attachment. By 111 | -- merging two import declarations, we lose that mapping. 112 | -- 113 | -- It's not really a big deal if we consider that people don't usually 114 | -- comment imports themselves. It _is_ however, systemic and it'd be better 115 | -- if we processed comments beforehand and attached them to all AST nodes in 116 | -- our own representation. 117 | mergeModuleImport 118 | :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs 119 | -> GHC.LImportDecl GHC.GhcPs 120 | mergeModuleImport (L p0 i0) (L _p1 i1) = 121 | L p0 $ i0 { ideclImportList = newImportNames } 122 | where 123 | newImportNames = 124 | case (ideclImportList i0, ideclImportList i1) of 125 | (Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1)) 126 | (Nothing, Nothing) -> Nothing 127 | (Just x, Nothing) -> Just x 128 | (Nothing, Just x) -> Just x 129 | merge xs ys 130 | = L.nubBy ((==) `on` showOutputable) (xs ++ ys) 131 | 132 | -- | Query the module AST using @f@ 133 | queryModule :: Typeable a => (a -> [b]) -> Module -> [b] 134 | queryModule f = everything (++) (mkQ [] f) 135 | 136 | moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)] 137 | moduleLanguagePragmas = 138 | mapMaybe prag . epAnnComments . GHC.hsmodAnn . GHC.hsmodExt . GHC.unLoc 139 | where 140 | prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String) 141 | prag comment = case GHC.ac_tok (GHC.unLoc comment) of 142 | GHC.EpaBlockComment str 143 | | lang : p1 : ps <- tokenize str, map toLower lang == "language" -> 144 | pure (GHC.epaLocationRealSrcSpan (GHC.getLoc comment), p1 :| ps) 145 | _ -> Nothing 146 | 147 | tokenize = words . 148 | map (\c -> if c == ',' then ' ' else c) . 149 | takeWhile (/= '#') . 150 | drop 1 . dropWhile (/= '#') 151 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Comments.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | Utilities for assocgating comments with things in a list. 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Language.Haskell.Stylish.Comments 6 | ( CommentGroup (..) 7 | , commentGroups 8 | , commentGroupHasComments 9 | , commentGroupSort 10 | ) where 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | import Data.Function (on) 15 | import Data.List (sortBy, sortOn) 16 | import Data.Maybe (isNothing, maybeToList) 17 | import qualified GHC.Hs as GHC 18 | import qualified GHC.Types.SrcLoc as GHC 19 | import qualified GHC.Utils.Outputable as GHC 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | import Language.Haskell.Stylish.Block 24 | import Language.Haskell.Stylish.GHC 25 | 26 | 27 | -------------------------------------------------------------------------------- 28 | data CommentGroup a = CommentGroup 29 | { cgBlock :: LineBlock 30 | , cgPrior :: [GHC.LEpaComment] 31 | , cgItems :: [(a, Maybe GHC.LEpaComment)] 32 | , cgFollowing :: [GHC.LEpaComment] 33 | } 34 | 35 | 36 | -------------------------------------------------------------------------------- 37 | instance GHC.Outputable a => Show (CommentGroup a) where 38 | show CommentGroup {..} = "(CommentGroup (" ++ 39 | show cgBlock ++ ") (" ++ 40 | showOutputable cgPrior ++ ") (" ++ 41 | showOutputable cgItems ++ ") (" ++ 42 | showOutputable cgFollowing ++ "))" 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | commentGroups 47 | :: forall a. 48 | (a -> Maybe GHC.RealSrcSpan) 49 | -> [a] 50 | -> [GHC.LEpaComment] 51 | -> [CommentGroup a] 52 | commentGroups getSpan allItems allComments = 53 | work Nothing (sortOn fst allItemsWithLines) (sortOn fst commentsWithLines) 54 | where 55 | allItemsWithLines :: [(LineBlock, a)] 56 | allItemsWithLines = do 57 | item <- allItems 58 | s <- maybeToList $ getSpan item 59 | pure (realSrcSpanToLineBlock s, item) 60 | 61 | commentsWithLines :: [(LineBlock, GHC.LEpaComment)] 62 | commentsWithLines = do 63 | comment <- allComments 64 | let s = GHC.epaLocationRealSrcSpan $ GHC.getLoc comment 65 | pure (realSrcSpanToLineBlock s, comment) 66 | 67 | work 68 | :: Maybe (CommentGroup a) 69 | -> [(LineBlock, a)] 70 | -> [(LineBlock, GHC.LEpaComment)] 71 | -> [CommentGroup a] 72 | work mbCurrent items comments = case takeNext items comments of 73 | Nothing -> maybeToList mbCurrent 74 | Just (b, next, items', comments') -> 75 | let (flush, current) = case mbCurrent of 76 | Just c | adjacent (cgBlock c) b 77 | , nextThingItem next 78 | , following@(_ : _) <- cgFollowing c -> 79 | ([c {cgFollowing = []}], CommentGroup b following [] []) 80 | Just c | adjacent (cgBlock c) b -> 81 | ([], c {cgBlock = cgBlock c <> b}) 82 | _ -> (maybeToList mbCurrent, CommentGroup b [] [] []) 83 | current' = case next of 84 | NextItem i -> current {cgItems = cgItems current <> [(i, Nothing)]} 85 | NextComment c 86 | | null (cgItems current) -> current {cgPrior = cgPrior current <> [c]} 87 | | otherwise -> current {cgFollowing = cgFollowing current <> [c]} 88 | NextItemWithComment i c -> 89 | current {cgItems = cgItems current <> [(i, Just c)]} in 90 | flush ++ work (Just current') items' comments' 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- 95 | takeNext 96 | :: [(LineBlock, a)] 97 | -> [(LineBlock, GHC.LEpaComment)] 98 | -> Maybe (LineBlock, NextThing a, [(LineBlock, a)], [(LineBlock, GHC.LEpaComment)]) 99 | takeNext [] [] = Nothing 100 | takeNext [] ((cb, c) : comments) = 101 | Just (cb, NextComment c, [], comments) 102 | takeNext ((ib, i) : items) [] = 103 | Just (ib, NextItem i, items, []) 104 | takeNext ((ib, i) : items) ((cb, c) : comments) 105 | | blockStart ib == blockStart cb = 106 | Just (ib <> cb, NextItemWithComment i c, items, comments) 107 | | blockStart ib < blockStart cb = 108 | Just (ib, NextItem i, items, (cb, c) : comments) 109 | | otherwise = 110 | Just (cb, NextComment c, (ib, i) : items, comments) 111 | 112 | 113 | -------------------------------------------------------------------------------- 114 | data NextThing a 115 | = NextComment GHC.LEpaComment 116 | | NextItem a 117 | | NextItemWithComment a GHC.LEpaComment 118 | 119 | 120 | -------------------------------------------------------------------------------- 121 | instance GHC.Outputable a => Show (NextThing a) where 122 | show (NextComment c) = "NextComment " ++ showOutputable c 123 | show (NextItem i) = "NextItem " ++ showOutputable i 124 | show (NextItemWithComment i c) = 125 | "NextItemWithComment " ++ showOutputable i ++ " " ++ showOutputable c 126 | 127 | 128 | -------------------------------------------------------------------------------- 129 | nextThingItem :: NextThing a -> Bool 130 | nextThingItem (NextComment _) = False 131 | nextThingItem (NextItem _) = True 132 | nextThingItem (NextItemWithComment _ _) = True 133 | 134 | 135 | -------------------------------------------------------------------------------- 136 | commentGroupHasComments :: CommentGroup a -> Bool 137 | commentGroupHasComments CommentGroup {..} = not $ 138 | null cgPrior && all (isNothing . snd) cgItems && null cgFollowing 139 | 140 | 141 | -------------------------------------------------------------------------------- 142 | commentGroupSort :: (a -> a -> Ordering) -> CommentGroup a -> CommentGroup a 143 | commentGroupSort cmp cg = cg 144 | { cgItems = sortBy (cmp `on` fst) (cgItems cg) 145 | } 146 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Config/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -------------------------------------------------------------------------------- 3 | module Language.Haskell.Stylish.Config.Cabal 4 | ( findLanguageExtensions 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Control.Monad (unless) 10 | import qualified Data.ByteString.Char8 as BS 11 | import Data.Foldable (traverse_) 12 | import Data.List (nub) 13 | import Data.Maybe (maybeToList) 14 | import qualified Distribution.PackageDescription as Cabal 15 | import qualified Distribution.PackageDescription.Parsec as Cabal 16 | import qualified Distribution.Parsec as Cabal 17 | import qualified Distribution.Simple.Utils as Cabal 18 | import qualified Distribution.Utils.Path as Cabal 19 | import qualified Distribution.Verbosity as Cabal 20 | import GHC.Data.Maybe (mapMaybe) 21 | import qualified Language.Haskell.Extension as Language 22 | import Language.Haskell.Stylish.Config.Internal 23 | import Language.Haskell.Stylish.Verbose 24 | import System.Directory (doesFileExist, 25 | getCurrentDirectory) 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | findLanguageExtensions 30 | :: Verbose -> ConfigSearchStrategy -> IO [(Language.KnownExtension, Bool)] 31 | findLanguageExtensions verbose configSearchStrategy = 32 | findCabalFile verbose configSearchStrategy >>= 33 | maybe (pure []) (readDefaultLanguageExtensions verbose) 34 | 35 | 36 | -------------------------------------------------------------------------------- 37 | -- | Find the closest .cabal file, possibly going up the directory structure. 38 | findCabalFile :: Verbose -> ConfigSearchStrategy -> IO (Maybe FilePath) 39 | findCabalFile verbose configSearchStrategy = case configSearchStrategy of 40 | -- If the invocation pointed us to a specific config file, it doesn't make 41 | -- much sense to search for cabal files manually (the config file could be 42 | -- somewhere like /etc, not necessarily a Haskell project). 43 | UseConfig _ -> pure Nothing 44 | SearchFromDirectory path -> go [] $ ancestors path 45 | SearchFromCurrentDirectory -> getCurrentDirectory >>= go [] . ancestors 46 | where 47 | go :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) 48 | go searched [] = do 49 | verbose $ ".cabal file not found, directories searched: " <> 50 | show searched 51 | verbose $ "Stylish Haskell will work basing on LANGUAGE pragmas in source files." 52 | return Nothing 53 | go searched (p : ps) = do 54 | 55 | #if MIN_VERSION_Cabal(3,14,0) 56 | let projectRoot = Just $ Cabal.makeSymbolicPath p 57 | potentialCabalFile <- Cabal.findPackageDesc projectRoot 58 | #else 59 | potentialCabalFile <- Cabal.findPackageDesc p 60 | #endif 61 | case potentialCabalFile of 62 | Right cabalFile -> pure $ Just $ 63 | #if MIN_VERSION_Cabal(3,14,0) 64 | Cabal.interpretSymbolicPath projectRoot cabalFile 65 | #else 66 | cabalFile 67 | #endif 68 | _ -> go (p : searched) ps 69 | 70 | 71 | -------------------------------------------------------------------------------- 72 | -- | Extract @default-extensions@ fields from a @.cabal@ file 73 | readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [(Language.KnownExtension, Bool)] 74 | readDefaultLanguageExtensions verbose cabalFile = do 75 | verbose $ "Parsing " <> cabalFile <> "..." 76 | packageDescription <- readGenericPackageDescription Cabal.silent cabalFile 77 | let library :: [Cabal.Library] 78 | library = maybeToList $ fst . Cabal.ignoreConditions <$> 79 | Cabal.condLibrary packageDescription 80 | 81 | subLibraries :: [Cabal.Library] 82 | subLibraries = fst . Cabal.ignoreConditions . snd <$> 83 | Cabal.condSubLibraries packageDescription 84 | 85 | executables :: [Cabal.Executable] 86 | executables = fst . Cabal.ignoreConditions . snd <$> 87 | Cabal.condExecutables packageDescription 88 | 89 | testSuites :: [Cabal.TestSuite] 90 | testSuites = fst . Cabal.ignoreConditions . snd <$> 91 | Cabal.condTestSuites packageDescription 92 | 93 | benchmarks :: [Cabal.Benchmark] 94 | benchmarks = fst . Cabal.ignoreConditions . snd <$> 95 | Cabal.condBenchmarks packageDescription 96 | 97 | gatherBuildInfos :: [Cabal.BuildInfo] 98 | gatherBuildInfos = map Cabal.libBuildInfo library <> 99 | map Cabal.libBuildInfo subLibraries <> 100 | map Cabal.buildInfo executables <> 101 | map Cabal.testBuildInfo testSuites <> 102 | map Cabal.benchmarkBuildInfo benchmarks 103 | 104 | defaultExtensions :: [(Language.KnownExtension, Bool)] 105 | defaultExtensions = mapMaybe toPair $ 106 | concatMap Cabal.defaultExtensions gatherBuildInfos 107 | where toPair (Language.EnableExtension x) = Just (x, True) 108 | toPair (Language.DisableExtension x) = Just (x, False) 109 | toPair _ = Nothing 110 | verbose $ "Gathered default-extensions: " <> show defaultExtensions 111 | pure $ nub defaultExtensions 112 | 113 | readGenericPackageDescription :: Cabal.Verbosity -> FilePath -> IO Cabal.GenericPackageDescription 114 | readGenericPackageDescription = readAndParseFile Cabal.parseGenericPackageDescription 115 | where 116 | readAndParseFile parser verbosity fpath = do 117 | exists <- doesFileExist fpath 118 | unless exists $ 119 | Cabal.die' verbosity $ 120 | "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." 121 | bs <- BS.readFile fpath 122 | parseString parser verbosity fpath bs 123 | 124 | parseString parser verbosity name bs = do 125 | let (warnings, result) = Cabal.runParseResult (parser bs) 126 | traverse_ (Cabal.warn verbosity . Cabal.showPWarning name) warnings 127 | case result of 128 | Right x -> return x 129 | Left (_, errors) -> do 130 | traverse_ (Cabal.warn verbosity . Cabal.showPError name) errors 131 | Cabal.die' verbosity $ "Failed parsing \"" ++ name ++ "\"." 132 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -------------------------------------------------------------------------------- 3 | module Main 4 | ( main 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Control.Monad (forM_, unless, when) 10 | import qualified Data.ByteString.Char8 as BC8 11 | import Data.Version (showVersion) 12 | import qualified Options.Applicative as OA 13 | import System.Exit (exitFailure) 14 | import qualified System.IO as IO 15 | import qualified System.IO.Strict as IO.Strict 16 | 17 | 18 | -------------------------------------------------------------------------------- 19 | import Language.Haskell.Stylish 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | data StylishArgs = StylishArgs 24 | { saVersion :: Bool 25 | , saConfig :: Maybe FilePath 26 | , saRecursive :: Bool 27 | , saVerbose :: Bool 28 | , saDefaults :: Bool 29 | , saInPlace :: Bool 30 | , saNoUtf8 :: Bool 31 | , saFiles :: [FilePath] 32 | } deriving (Show) 33 | 34 | 35 | -------------------------------------------------------------------------------- 36 | parseStylishArgs :: OA.Parser StylishArgs 37 | parseStylishArgs = StylishArgs 38 | <$> OA.switch ( 39 | OA.help "Show version information" <> 40 | OA.long "version" <> 41 | OA.hidden) 42 | <*> OA.optional (OA.strOption $ 43 | OA.metavar "CONFIG" <> 44 | OA.help "Configuration file" <> 45 | OA.long "config" <> 46 | OA.short 'c' <> 47 | OA.hidden) 48 | <*> OA.switch ( 49 | OA.help "Recursive file search" <> 50 | OA.long "recursive" <> 51 | OA.short 'r' <> 52 | OA.hidden) 53 | <*> OA.switch ( 54 | OA.help "Run in verbose mode" <> 55 | OA.long "verbose" <> 56 | OA.short 'v' <> 57 | OA.hidden) 58 | <*> OA.switch ( 59 | OA.help "Dump default config and exit" <> 60 | OA.long "defaults" <> 61 | OA.short 'd' <> 62 | OA.hidden) 63 | <*> OA.switch ( 64 | OA.help "Overwrite the given files in place" <> 65 | OA.long "inplace" <> 66 | OA.short 'i' <> 67 | OA.hidden) 68 | <*> OA.switch ( 69 | OA.help "Don't force UTF-8 stdin/stdout" <> 70 | OA.long "no-utf8" <> 71 | OA.hidden) 72 | <*> OA.many (OA.strArgument $ 73 | OA.metavar "FILENAME" <> 74 | OA.help "Input file(s)") 75 | 76 | 77 | -------------------------------------------------------------------------------- 78 | stylishHaskellVersion :: String 79 | stylishHaskellVersion = "stylish-haskell " <> showVersion version 80 | 81 | 82 | -------------------------------------------------------------------------------- 83 | parserInfo :: OA.ParserInfo StylishArgs 84 | parserInfo = OA.info (OA.helper <*> parseStylishArgs) $ 85 | OA.fullDesc <> 86 | OA.header stylishHaskellVersion 87 | 88 | 89 | -------------------------------------------------------------------------------- 90 | main :: IO () 91 | main = OA.execParser parserInfo >>= stylishHaskell 92 | 93 | 94 | -------------------------------------------------------------------------------- 95 | stylishHaskell :: StylishArgs -> IO () 96 | stylishHaskell sa = do 97 | unless (saNoUtf8 sa) $ 98 | mapM_ (`IO.hSetEncoding` IO.utf8) [IO.stdin, IO.stdout] 99 | if saVersion sa then 100 | putStrLn stylishHaskellVersion 101 | 102 | else if saDefaults sa then do 103 | verbose' "Dumping embedded config..." 104 | BC8.putStr defaultConfigBytes 105 | 106 | else do 107 | conf <- loadConfig verbose' $ 108 | maybe SearchFromCurrentDirectory UseConfig (saConfig sa) 109 | filesR <- case (saRecursive sa) of 110 | True -> findHaskellFiles (saVerbose sa) (saFiles sa) 111 | _ -> return $ saFiles sa 112 | let steps = configSteps conf 113 | forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" 114 | verbose' $ "Extra language extensions: " ++ 115 | show (configLanguageExtensions conf) 116 | res <- foldMap (file sa conf) (files' filesR) 117 | 118 | verbose' $ "Exit code behavior: " ++ show (configExitCode conf) 119 | when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat) exitFailure 120 | where 121 | verbose' = makeVerbose (saVerbose sa) 122 | files' x = case (saRecursive sa, null x) of 123 | (True,True) -> [] -- No file to format and recursive enabled. 124 | (_,True) -> [Nothing] -- Involving IO.stdin. 125 | (_,False) -> map Just x -- Process available files. 126 | 127 | data FormattingResult 128 | = DidFormat 129 | | NoChange 130 | deriving (Eq) 131 | 132 | instance Semigroup FormattingResult where 133 | _ <> DidFormat = DidFormat 134 | DidFormat <> _ = DidFormat 135 | _ <> _ = NoChange 136 | 137 | instance Monoid FormattingResult where 138 | mempty = NoChange 139 | 140 | -------------------------------------------------------------------------------- 141 | -- | Processes a single file, or stdin if no filepath is given 142 | file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult 143 | file sa conf mfp = do 144 | contents <- maybe getContents readUTF8File mfp 145 | let 146 | inputLines = 147 | lines contents 148 | result = 149 | runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines 150 | case result of 151 | Right ok -> do 152 | write contents (unlines ok) 153 | pure $ if ok /= inputLines then DidFormat else NoChange 154 | Left err -> do 155 | IO.hPutStrLn IO.stderr err 156 | exitFailure 157 | where 158 | write old new = case mfp of 159 | Nothing -> putStrNewline new 160 | Just _ | not (saInPlace sa) -> putStrNewline new 161 | Just path | not (null new) && old /= new -> 162 | IO.withFile path IO.WriteMode $ \h -> do 163 | setNewlineMode h 164 | IO.hPutStr h new 165 | _ -> return () 166 | setNewlineMode h = do 167 | let nl = configNewline conf 168 | let mode = IO.NewlineMode IO.nativeNewline nl 169 | IO.hSetNewlineMode h mode 170 | putStrNewline txt = setNewlineMode IO.stdout >> putStr txt 171 | 172 | readUTF8File :: FilePath -> IO String 173 | readUTF8File fp = 174 | IO.withFile fp IO.ReadMode $ \h -> do 175 | IO.hSetEncoding h IO.utf8 176 | IO.Strict.hGetContents h 177 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Editor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -------------------------------------------------------------------------------- 4 | -- | This module provides you with a line-based editor. It's main feature is 5 | -- that you can specify multiple changes at the same time, e.g.: 6 | -- 7 | -- > [deleteLine 3, changeLine 4 ["Foo"]] 8 | -- 9 | -- when this is evaluated, we take into account that 4th line will become the 10 | -- 3rd line before it needs changing. 11 | module Language.Haskell.Stylish.Editor 12 | ( module Language.Haskell.Stylish.Block 13 | 14 | , Edits 15 | , apply 16 | 17 | , replace 18 | , replaceRealSrcSpan 19 | , changeLine 20 | , changeLines 21 | , insertLines 22 | ) where 23 | 24 | 25 | -------------------------------------------------------------------------------- 26 | import qualified Data.Map as M 27 | import Data.Maybe (fromMaybe) 28 | import qualified GHC.Types.SrcLoc as GHC 29 | 30 | 31 | -------------------------------------------------------------------------------- 32 | import Language.Haskell.Stylish.Block 33 | 34 | 35 | -------------------------------------------------------------------------------- 36 | data Change 37 | -- | Insert some lines. 38 | = CInsert [String] 39 | -- | Replace the block of N lines by the given lines. 40 | | CBlock Int ([String] -> [String]) 41 | -- | Replace (startCol, endCol) by the given string on this line. 42 | | CLine Int Int String 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | -- | Due to the function in CBlock we cannot write a lawful Ord instance, but 47 | -- this lets us merge-sort changes. 48 | beforeChange :: Change -> Change -> Bool 49 | beforeChange (CInsert _) _ = True 50 | beforeChange _ (CInsert _) = False 51 | beforeChange (CBlock _ _) _ = True 52 | beforeChange _ (CBlock _ _) = False 53 | beforeChange (CLine x _ _) (CLine y _ _) = x <= y 54 | 55 | 56 | -------------------------------------------------------------------------------- 57 | prettyChange :: Int -> Change -> String 58 | prettyChange l (CInsert ls) = 59 | show l ++ " insert " ++ show (length ls) ++ " lines" 60 | prettyChange l (CBlock n _) = show l ++ "-" ++ show (l + n) ++ " replace lines" 61 | prettyChange l (CLine start end x) = 62 | show l ++ ":" ++ show start ++ "-" ++ show end ++ " replace by " ++ show x 63 | 64 | 65 | -------------------------------------------------------------------------------- 66 | -- | Merge in order 67 | mergeChanges :: [Change] -> [Change] -> [Change] 68 | mergeChanges = go 69 | where 70 | go [] ys = ys 71 | go xs [] = xs 72 | go (x : xs) (y : ys) = 73 | if x `beforeChange` y then x : go xs (y : ys) else y : go (x : xs) ys 74 | 75 | 76 | -------------------------------------------------------------------------------- 77 | -- Stores sorted spans to change per line. 78 | newtype Edits = Edits {unEdits :: M.Map Int [Change]} 79 | 80 | 81 | -------------------------------------------------------------------------------- 82 | instance Show Edits where 83 | show edits = unlines $ do 84 | (line, changes) <- M.toAscList $ unEdits edits 85 | prettyChange line <$> changes 86 | 87 | 88 | -------------------------------------------------------------------------------- 89 | instance Semigroup Edits where 90 | Edits l <> Edits r = Edits $ M.unionWith mergeChanges l r 91 | 92 | 93 | -------------------------------------------------------------------------------- 94 | instance Monoid Edits where 95 | mempty = Edits mempty 96 | 97 | 98 | -------------------------------------------------------------------------------- 99 | replaceRealSrcSpan :: GHC.RealSrcSpan -> String -> Edits 100 | replaceRealSrcSpan rss repl 101 | | GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = mempty 102 | | otherwise = replace 103 | (GHC.srcSpanStartLine rss) 104 | (GHC.srcSpanStartCol rss) 105 | (GHC.srcSpanEndCol rss) 106 | repl 107 | 108 | 109 | -------------------------------------------------------------------------------- 110 | replace :: Int -> Int -> Int -> String -> Edits 111 | replace line startCol endCol repl 112 | | startCol > endCol = mempty 113 | | otherwise = 114 | Edits $ M.singleton line [CLine startCol endCol repl] 115 | 116 | 117 | -------------------------------------------------------------------------------- 118 | changeLine :: Int -> (String -> [String]) -> Edits 119 | changeLine start f = changeLines (Block start start) $ \ls -> case ls of 120 | l : _ -> f l 121 | _ -> f "" 122 | 123 | 124 | -------------------------------------------------------------------------------- 125 | changeLines :: Block String -> ([String] -> [String]) -> Edits 126 | changeLines (Block start end) f = 127 | Edits $ M.singleton start [CBlock (end - start + 1) f] 128 | 129 | 130 | -------------------------------------------------------------------------------- 131 | insertLines :: Int -> [String] -> Edits 132 | insertLines line ls = Edits $ M.singleton line [CInsert ls] 133 | 134 | 135 | -------------------------------------------------------------------------------- 136 | data Conflict = Conflict Int Change Int Change 137 | 138 | 139 | -------------------------------------------------------------------------------- 140 | prettyConflict :: Conflict -> String 141 | prettyConflict (Conflict l1 c1 l2 c2) = unlines 142 | [ "Conflict between edits:" 143 | , "- " ++ prettyChange l1 c1 144 | , "- " ++ prettyChange l2 c2 145 | ] 146 | 147 | 148 | -------------------------------------------------------------------------------- 149 | conflicts :: Edits -> [Conflict] 150 | conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges 151 | where 152 | checkChanges _ [] = [] 153 | checkChanges i (CInsert _ : cs) = checkChanges i cs 154 | checkChanges i (c1@(CBlock _ _) : c2 : _) = [Conflict i c1 i c2] 155 | checkChanges i [c1@(CBlock n _)] = do 156 | i' <- [i + 1 .. i + n - 1] 157 | case M.lookup i' edits of 158 | Just (c2 : _) -> [Conflict i c1 i' c2] 159 | _ -> [] 160 | checkChanges i (c1@(CLine xstart xend _) : c2@(CLine ystart _ _) : cs) 161 | | xstart == ystart = [Conflict i c1 i c2] 162 | | xend > ystart = [Conflict i c1 i c2] 163 | | otherwise = checkChanges i (c2 : cs) 164 | checkChanges _ (CLine _ _ _ : _) = [] 165 | 166 | 167 | -------------------------------------------------------------------------------- 168 | apply :: Edits -> [String] -> [String] 169 | apply (Edits edits) = case conflicts (Edits edits) of 170 | c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c 171 | _ -> go 1 (editsFor 1) 172 | where 173 | editsFor i = fromMaybe [] $ M.lookup i edits 174 | 175 | go _ _ [] = [] 176 | go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls 177 | go i (CInsert ls' : cs) ls = ls' ++ go i cs ls 178 | go i (CBlock n f : _cs) ls = 179 | let (domain, ls') = splitAt n ls in 180 | f domain ++ go (i + n) (editsFor $ i + n) ls' 181 | go i (CLine xstart xend x : cs) (l : ls) = 182 | let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in 183 | go i (adjust xstart xend x <$> cs) (l' : ls) 184 | 185 | adjust _ _ _ (CInsert xs) = CInsert xs 186 | adjust _ _ _ (CBlock n f) = CBlock n f 187 | adjust xstart xend x (CLine ystart yend y) 188 | | ystart >= xend = 189 | let offset = length x - (xend - xstart) in 190 | CLine (ystart + offset) (yend + offset) y 191 | | otherwise = CLine ystart yend y 192 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/SimpleAlign.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Language.Haskell.Stylish.Step.SimpleAlign 5 | ( Config (..) 6 | , Align (..) 7 | , defaultConfig 8 | , step 9 | ) where 10 | 11 | 12 | -------------------------------------------------------------------------------- 13 | import Data.Either (partitionEithers) 14 | import Data.Foldable (toList) 15 | import Data.List (foldl', foldl1', sortOn) 16 | import Data.Maybe (fromMaybe) 17 | import qualified GHC.Hs as Hs 18 | import qualified GHC.Parser.Annotation as GHC 19 | import qualified GHC.Types.SrcLoc as GHC 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | import Language.Haskell.Stylish.Align 24 | import qualified Language.Haskell.Stylish.Editor as Editor 25 | import Language.Haskell.Stylish.GHC 26 | import Language.Haskell.Stylish.Module 27 | import Language.Haskell.Stylish.Step 28 | import Language.Haskell.Stylish.Util 29 | 30 | 31 | -------------------------------------------------------------------------------- 32 | data Config = Config 33 | { cCases :: Align 34 | , cTopLevelPatterns :: Align 35 | , cRecords :: Align 36 | , cMultiWayIf :: Align 37 | } deriving (Show) 38 | 39 | data Align 40 | = Always 41 | | Adjacent 42 | | Never 43 | deriving (Eq, Show) 44 | 45 | defaultConfig :: Config 46 | defaultConfig = Config 47 | { cCases = Always 48 | , cTopLevelPatterns = Always 49 | , cRecords = Always 50 | , cMultiWayIf = Always 51 | } 52 | 53 | groupAlign :: Align -> [Alignable GHC.RealSrcSpan] -> [[Alignable GHC.RealSrcSpan]] 54 | groupAlign a xs = case a of 55 | Never -> [] 56 | Adjacent -> byLine . sortOn (GHC.srcSpanStartLine . aLeft) $ xs 57 | Always -> [xs] 58 | where 59 | byLine = map toList . groupByLine aLeft 60 | 61 | 62 | -------------------------------------------------------------------------------- 63 | type Record = [GHC.LocatedA (Hs.ConDeclField Hs.GhcPs)] 64 | 65 | 66 | -------------------------------------------------------------------------------- 67 | records :: Module -> [Record] 68 | records modu = do 69 | let decls = map GHC.unLoc (Hs.hsmodDecls (GHC.unLoc modu)) 70 | tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] 71 | dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] 72 | dataDefns = map Hs.tcdDataDefn dataDecls 73 | d@Hs.ConDeclH98 {} <- GHC.unLoc <$> concatMap getConDecls dataDefns 74 | case Hs.con_args d of 75 | Hs.RecCon rec -> [GHC.unLoc rec] 76 | _ -> [] 77 | 78 | -------------------------------------------------------------------------------- 79 | recordToAlignable :: Config -> Record -> [[Alignable GHC.RealSrcSpan]] 80 | recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fieldDeclToAlignable 81 | 82 | 83 | -------------------------------------------------------------------------------- 84 | fieldDeclToAlignable 85 | :: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan) 86 | fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do 87 | matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc 88 | leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA $ last names 89 | tyPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA ty 90 | Just $ Alignable 91 | { aContainer = matchPos 92 | , aLeft = leftPos 93 | , aRight = tyPos 94 | , aRightLead = length ":: " 95 | } 96 | 97 | 98 | -------------------------------------------------------------------------------- 99 | matchGroupToAlignable 100 | :: Config 101 | -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) 102 | -> [[Alignable GHC.RealSrcSpan]] 103 | matchGroupToAlignable conf mg = cases' ++ patterns' 104 | where 105 | alts = Hs.mg_alts mg 106 | (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (GHC.unLoc alts) 107 | cases' = groupAlign (cCases conf) cases 108 | patterns' = groupAlign (cTopLevelPatterns conf) patterns 109 | 110 | 111 | -------------------------------------------------------------------------------- 112 | matchToAlignable 113 | :: GHC.LocatedA (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) 114 | -> Maybe (Either (Alignable GHC.RealSrcSpan) (Alignable GHC.RealSrcSpan)) 115 | matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt (GHC.L _ pats@(_ : _)) grhss)) = do 116 | let patsLocs = map GHC.getLocA pats 117 | pat = last patsLocs 118 | guards = getGuards m 119 | guardsLocs = map GHC.getLocA guards 120 | left = foldl' GHC.combineSrcSpans pat guardsLocs 121 | body <- rhsBody grhss 122 | matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc 123 | leftPos <- GHC.srcSpanToRealSrcSpan left 124 | rightPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body 125 | Just . Left $ Alignable 126 | { aContainer = matchPos 127 | , aLeft = leftPos 128 | , aRight = rightPos 129 | , aRightLead = length "-> " 130 | } 131 | matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _ _) (GHC.L _ pats@(_ : _)) grhss)) = do 132 | body <- unguardedRhsBody grhss 133 | let patsLocs = map GHC.getLocA pats 134 | nameLoc = GHC.getLocA name 135 | left = last (nameLoc : patsLocs) 136 | bodyLoc = GHC.getLocA body 137 | matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc 138 | leftPos <- GHC.srcSpanToRealSrcSpan left 139 | bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc 140 | Just . Right $ Alignable 141 | { aContainer = matchPos 142 | , aLeft = leftPos 143 | , aRight = bodyPos 144 | , aRightLead = length "= " 145 | } 146 | matchToAlignable (GHC.L _ (Hs.Match _ _ _ _)) = Nothing 147 | 148 | 149 | -------------------------------------------------------------------------------- 150 | multiWayIfToAlignable 151 | :: Config 152 | -> Hs.LHsExpr Hs.GhcPs 153 | -> [[Alignable GHC.RealSrcSpan]] 154 | multiWayIfToAlignable conf (GHC.L _ (Hs.HsMultiIf _ grhss)) = 155 | groupAlign (cMultiWayIf conf) as 156 | where 157 | as = fromMaybe [] $ traverse grhsToAlignable grhss 158 | multiWayIfToAlignable _conf _ = [] 159 | 160 | 161 | -------------------------------------------------------------------------------- 162 | grhsToAlignable 163 | :: GHC.GenLocated (GHC.EpAnnCO) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) 164 | -> Maybe (Alignable GHC.RealSrcSpan) 165 | grhsToAlignable (GHC.L (GHC.EpAnn (GHC.EpaSpan grhsloc) _ _ ) (Hs.GRHS _ guards@(_ : _) body)) = do 166 | let guardsLocs = map GHC.getLocA guards 167 | bodyLoc = GHC.getLocA $ body 168 | left = foldl1' GHC.combineSrcSpans guardsLocs 169 | matchPos <- GHC.srcSpanToRealSrcSpan grhsloc 170 | leftPos <- GHC.srcSpanToRealSrcSpan left 171 | bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc 172 | Just $ Alignable 173 | { aContainer = matchPos 174 | , aLeft = leftPos 175 | , aRight = bodyPos 176 | , aRightLead = length "-> " 177 | } 178 | grhsToAlignable (GHC.L _ _) = Nothing 179 | 180 | 181 | -------------------------------------------------------------------------------- 182 | step :: Maybe Int -> Config -> Step 183 | step maxColumns config = makeStep "Cases" $ \ls module' -> 184 | let changes 185 | :: (Module -> [a]) 186 | -> (a -> [[Alignable GHC.RealSrcSpan]]) 187 | -> Editor.Edits 188 | changes search toAlign = mconcat $ do 189 | item <- search module' 190 | pure $ foldMap (align maxColumns) (toAlign item) 191 | 192 | configured :: Editor.Edits 193 | configured = 194 | changes records (recordToAlignable config) <> 195 | changes everything (matchGroupToAlignable config) <> 196 | changes everything (multiWayIfToAlignable config) in 197 | Editor.apply configured ls 198 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | ## stylish-haskell 2 | 3 | 4 | 5 | ![Stack Build Status](https://github.com/jaspervdj/stylish-haskell/workflows/CI/badge.svg) 6 | ![Cabal Build Status](https://github.com/jaspervdj/stylish-haskell/workflows/Cabal/badge.svg) 7 | 8 | ## Introduction 9 | 10 | A simple Haskell code prettifier. The goal is not to format all of the code in 11 | a file, since I find those kind of tools often "get in the way". However, 12 | manually cleaning up import statements etc. gets tedious very quickly. 13 | 14 | This tool tries to help where necessary without getting in the way. 15 | 16 | ## Installation 17 | 18 | You can install it using `stack install stylish-haskell` or `cabal install stylish-haskell`. 19 | 20 | You can also install it using your package manager: 21 | 22 | - Debian 9 or later: `apt-get install stylish-haskell` 23 | - Ubuntu 16.10 or later: `apt-get install stylish-haskell` 24 | - Arch Linux: `pacman -S stylish-haskell` 25 | 26 | ## Features 27 | 28 | - Aligns and sorts `import` statements 29 | - Groups and wraps `{-# LANGUAGE #-}` pragmas, can remove (some) redundant 30 | pragmas 31 | - Removes trailing whitespace 32 | - Aligns branches in `case` and fields in records 33 | - Converts line endings (customizable) 34 | - Replaces tabs by four spaces (turned off by default) 35 | - Replaces some ASCII sequences by their Unicode equivalents (turned off by 36 | default) 37 | - Format data constructors and fields in records. 38 | 39 | Feature requests are welcome! Use the [issue tracker] for that. 40 | 41 | [issue tracker]: https://github.com/haskell/stylish-haskell/issues 42 | 43 | ## Example 44 | 45 | Turns: 46 | 47 | ```haskell 48 | {-# LANGUAGE ViewPatterns, TemplateHaskell #-} 49 | {-# LANGUAGE GeneralizedNewtypeDeriving, 50 | ViewPatterns, 51 | ScopedTypeVariables #-} 52 | 53 | module Bad where 54 | 55 | import Control.Applicative ((<$>)) 56 | import System.Directory (doesFileExist) 57 | 58 | import qualified Data.Map as M 59 | import Data.Map ((!), keys, Map) 60 | 61 | data Point = Point { pointX, pointY :: Double , pointName :: String} deriving (Show) 62 | ``` 63 | 64 | into: 65 | 66 | ```haskell 67 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 68 | {-# LANGUAGE ScopedTypeVariables #-} 69 | {-# LANGUAGE TemplateHaskell #-} 70 | 71 | module Bad where 72 | 73 | import Control.Applicative ((<$>)) 74 | import System.Directory (doesFileExist) 75 | 76 | import Data.Map (Map, keys, (!)) 77 | import qualified Data.Map as M 78 | 79 | data Point = Point 80 | { pointX, pointY :: Double 81 | , pointName :: String 82 | } deriving (Show) 83 | ``` 84 | 85 | ## Configuration 86 | 87 | The tool is customizable to some extent. It tries to find a config file in the 88 | following order: 89 | 90 | 1. A file passed to the tool using the `-c/--config` argument 91 | 2. `.stylish-haskell.yaml` in the current directory (useful for per-directory 92 | settings) 93 | 3. `.stylish-haskell.yaml` in the nearest ancestor directory (useful for 94 | per-project settings) 95 | 4. `stylish-haskell/config.yaml` in the platform’s configuration directory 96 | (on Windows, it is %APPDATA%, elsewhere it defaults to `~/.config` and 97 | can be overridden by the `XDG_CONFIG_HOME` environment variable; 98 | useful for user-wide settings) 99 | 5. `.stylish-haskell.yaml` in your home directory (useful for user-wide 100 | settings) 101 | 6. The default settings. 102 | 103 | Use `stylish-haskell --defaults > .stylish-haskell.yaml` to dump a 104 | well-documented default configuration to a file, this way you can get started 105 | quickly. 106 | 107 | ## Record formatting 108 | 109 | Basically, stylish-haskell supports 4 different styles of records, controlled by `records` 110 | in the config file. 111 | 112 | Here's an example of all four styles: 113 | 114 | ```haskell 115 | -- equals: "indent 2", "first_field": "indent 2" 116 | data Foo a 117 | = Foo 118 | { a :: Int 119 | , a2 :: String 120 | -- ^ some haddock 121 | } 122 | | Bar 123 | { b :: a 124 | } 125 | deriving (Eq, Show) 126 | deriving (ToJSON) via Bar Foo 127 | 128 | -- equals: "same_line", "first_field": "indent 2" 129 | data Foo a = Foo 130 | { a :: Int 131 | , a2 :: String 132 | -- ^ some haddock 133 | } 134 | | Bar 135 | { b :: a 136 | } 137 | deriving (Eq, Show) 138 | deriving (ToJSON) via Bar Foo 139 | 140 | -- equals: "same_line", "first_field": "same_line" 141 | data Foo a = Foo { a :: Int 142 | , a2 :: String 143 | -- ^ some haddock 144 | } 145 | | Bar { b :: a 146 | } 147 | deriving (Eq, Show) 148 | deriving (ToJSON) via Bar Foo 149 | 150 | -- equals: "indent 2", first_field: "same_line" 151 | data Foo a 152 | = Foo { a :: Int 153 | , a2 :: String 154 | -- ^ some haddock 155 | } 156 | | Bar { b :: a 157 | } 158 | deriving (Eq, Show) 159 | deriving (ToJSON) via Bar Foo 160 | ``` 161 | 162 | ## Editor integration 163 | 164 | ### Haskell Language Server 165 | [Haskell Language Server(HLS)][HLS] includes a [plugin][HLS stylish-haskell Plugin] 166 | for stylish-haskell. By changing the formatting provider option 167 | (`haskell.formattingProvider`) to `stylish-haskell` as described in 168 | [HLS options][HLS option], any editors that support [Language Server Protocol][LSP] 169 | can use stylish-haskell for formatting. 170 | 171 | [HLS]: https://github.com/haskell/haskell-language-server 172 | [HLS option]: https://haskell-language-server.readthedocs.io/en/latest/configuration.html#language-specific-server-options 173 | [HLS stylish-haskell Plugin]: https://github.com/haskell/haskell-language-server/blob/master/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs 174 | [LSP]: https://microsoft.github.io/language-server-protocol/ 175 | 176 | ### VIM integration 177 | 178 | Since it works as a filter it is pretty easy to integrate this with VIM. 179 | 180 | You can call 181 | 182 | :%!stylish-haskell 183 | 184 | and add a keybinding for it. 185 | 186 | Or you can define `formatprg` 187 | 188 | :set formatprg=stylish-haskell 189 | 190 | and then use `gq`. 191 | 192 | Alternatively, [vim-autoformat] supports stylish-haskell. To have it 193 | automatically reformat the files on save, add to your vimrc: 194 | 195 | ```vim 196 | autocmd BufWrite *.hs :Autoformat 197 | " Don't automatically indent on save, since vim's autoindent for haskell is buggy 198 | autocmd FileType haskell let b:autoformat_autoindent=0 199 | ``` 200 | 201 | There are also plugins that run stylish-haskell automatically when you save a 202 | Haskell file: 203 | 204 | - [vim-stylish-haskell] 205 | - [vim-stylishask] 206 | 207 | [vim-stylish-haskell]: https://github.com/nbouscal/vim-stylish-haskell 208 | [vim-stylishask]: https://github.com/alx741/vim-stylishask 209 | 210 | ### Emacs integration 211 | 212 | [haskell-mode] for Emacs supports `stylish-haskell`. For configuration, 213 | see [the “Using external formatters” section][haskell-mode/format] of the 214 | haskell-mode manual. 215 | 216 | [haskell-mode]: https://github.com/haskell/haskell-mode 217 | [haskell-mode/format]: http://haskell.github.io/haskell-mode/manual/latest/Autoformating.html 218 | 219 | ### Atom integration 220 | 221 | [ide-haskell] for Atom supports `stylish-haskell`. 222 | 223 | [atom-beautify] for Atom supports Haskell using `stylish-haskell`. 224 | 225 | [ide-haskell]: https://atom.io/packages/ide-haskell 226 | [atom-beautify]: Https://atom.io/packages/atom-beautify 227 | 228 | ### Visual Studio Code integration 229 | 230 | [stylish-haskell-vscode] for VSCode supports `stylish-haskell`. 231 | 232 | [stylish-haskell-vscode]: https://github.com/vigoo/stylish-haskell-vscode 233 | 234 | ## Using with Continuous Integration 235 | 236 | You can quickly grab the latest binary and run `stylish-haskell` like so: 237 | 238 | curl -sL https://raw.github.com/haskell/stylish-haskell/master/scripts/latest.sh | sh -s . 239 | 240 | Where the `.` can be replaced with the arguments you pass to `stylish-haskell`. 241 | 242 | ## Credits 243 | 244 | Written and maintained by Jasper Van der Jeugt. 245 | 246 | Contributors: 247 | 248 | - Chris Done 249 | - Hiromi Ishii 250 | - Leonid Onokhov 251 | - Michael Snoyman 252 | - Mikhail Glushenkov 253 | - Beatrice Vergani 254 | - Paweł Szulc 255 | - Łukasz Gołębiewski 256 | - Felix Mulder 257 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Language.Haskell.Stylish.Step.LanguagePragmas 6 | ( Style (..) 7 | , step 8 | -- * Utilities 9 | , addLanguagePragma 10 | ) where 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | import Data.List.NonEmpty (NonEmpty, fromList, toList) 15 | import qualified Data.Set as S 16 | 17 | 18 | -------------------------------------------------------------------------------- 19 | import qualified GHC.Hs as GHC 20 | import qualified GHC.Types.SrcLoc as GHC 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | import Language.Haskell.Stylish.Block 25 | import qualified Language.Haskell.Stylish.Editor as Editor 26 | import Language.Haskell.Stylish.Module 27 | import Language.Haskell.Stylish.Step 28 | import Language.Haskell.Stylish.Util 29 | 30 | 31 | -------------------------------------------------------------------------------- 32 | data Style 33 | = Vertical 34 | | Compact 35 | | CompactLine 36 | | VerticalCompact 37 | deriving (Eq, Show) 38 | 39 | 40 | -------------------------------------------------------------------------------- 41 | verticalPragmas :: String -> Int -> Bool -> [String] -> Lines 42 | verticalPragmas lg longest align pragmas' = 43 | [ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}" 44 | | pragma <- pragmas' 45 | ] 46 | where 47 | pad 48 | | align = padRight longest 49 | | otherwise = id 50 | 51 | 52 | -------------------------------------------------------------------------------- 53 | compactPragmas :: String -> Maybe Int -> [String] -> Lines 54 | compactPragmas lg columns pragmas' = wrapMaybe columns ("{-# " ++ lg) 13 $ 55 | map (++ ",") (init pragmas') ++ [last pragmas' ++ " #-}"] 56 | 57 | 58 | -------------------------------------------------------------------------------- 59 | compactLinePragmas :: String -> Maybe Int -> Bool -> [String] -> Lines 60 | compactLinePragmas _ _ _ [] = [] 61 | compactLinePragmas lg columns align pragmas' = map (wrapLanguage . pad) prags 62 | where 63 | wrapLanguage ps = "{-# " ++ lg ++ ps ++ " #-}" 64 | maxWidth = fmap (\c -> c - 16) columns 65 | longest = maximum $ map length prags 66 | pad 67 | | align = padRight longest 68 | | otherwise = id 69 | prags = map truncateComma $ wrapMaybe maxWidth "" 1 $ 70 | map (++ ",") (init pragmas') ++ [last pragmas'] 71 | 72 | 73 | -------------------------------------------------------------------------------- 74 | verticalCompactPragmas :: String -> [String] -> Lines 75 | verticalCompactPragmas lg pragmas' = 76 | [ "{-# " <> lg 77 | , " " <> head pragmas' 78 | ] 79 | <> [ " , " <> pragma | pragma <- tail pragmas'] 80 | <> [ " #-}"] 81 | 82 | 83 | -------------------------------------------------------------------------------- 84 | truncateComma :: String -> String 85 | truncateComma "" = "" 86 | truncateComma xs 87 | | last xs == ',' = init xs 88 | | otherwise = xs 89 | 90 | 91 | -------------------------------------------------------------------------------- 92 | prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> [String] -> Lines 93 | prettyPragmas lp _ longest align Vertical = verticalPragmas lp longest align 94 | prettyPragmas lp cols _ _ Compact = compactPragmas lp cols 95 | prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols align 96 | prettyPragmas lp _ _ _ VerticalCompact = verticalCompactPragmas lp 97 | 98 | 99 | -------------------------------------------------------------------------------- 100 | -- | Filter redundant (and duplicate) pragmas out of the groups. As a side 101 | -- effect, we also sort the pragmas in their group... 102 | filterRedundant :: (String -> Bool) 103 | -> [(l, NonEmpty String)] 104 | -> [(l, [String])] 105 | filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList) 106 | where 107 | filterRedundant' (l, xs) (known, zs) 108 | | S.null xs' = (known', zs) 109 | | otherwise = (known', (l, S.toAscList xs') : zs) 110 | where 111 | fxs = filter (not . isRedundant') xs 112 | xs' = S.fromList fxs `S.difference` known 113 | known' = xs' `S.union` known 114 | 115 | -------------------------------------------------------------------------------- 116 | step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step 117 | step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' 118 | 119 | 120 | -------------------------------------------------------------------------------- 121 | step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines 122 | step' columns style align removeRedundant lngPrefix ls m 123 | | null languagePragmas = ls 124 | | otherwise = Editor.apply changes ls 125 | where 126 | isRedundant' 127 | | removeRedundant = isRedundant m 128 | | otherwise = const False 129 | 130 | languagePragmas = moduleLanguagePragmas m 131 | 132 | convertFstToBlock :: [(GHC.RealSrcSpan, a)] -> [(Block String, a)] 133 | convertFstToBlock = fmap \(rspan, a) -> 134 | (Block (GHC.srcSpanStartLine rspan) (GHC.srcSpanEndLine rspan), a) 135 | 136 | groupAdjacent' = 137 | fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList) 138 | where 139 | turnSndBackToNel (a, bss) = (a, fromList . concat $ bss) 140 | 141 | longest :: Int 142 | longest = maximum $ map length $ toList . snd =<< languagePragmas 143 | 144 | groups :: [(Block String, NonEmpty String)] 145 | groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] 146 | 147 | changes = mconcat 148 | [ Editor.changeLines b (const $ prettyPragmas lngPrefix columns longest align style pg) 149 | | (b, pg) <- filterRedundant isRedundant' groups 150 | ] 151 | 152 | 153 | -------------------------------------------------------------------------------- 154 | -- | Add a LANGUAGE pragma to a module if it is not present already. 155 | addLanguagePragma :: String -> String -> Module -> Editor.Edits 156 | addLanguagePragma lg prag modu 157 | | prag `elem` present = mempty 158 | | otherwise = Editor.insertLines line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"] 159 | where 160 | pragmas' = moduleLanguagePragmas modu 161 | present = concatMap (toList . snd) pragmas' 162 | line = if null pragmas' then 1 else firstLocation pragmas' 163 | firstLocation :: [(GHC.RealSrcSpan, NonEmpty String)] -> Int 164 | firstLocation = minimum . fmap (GHC.srcLocLine . GHC.realSrcSpanStart . fst) 165 | 166 | 167 | -------------------------------------------------------------------------------- 168 | -- | Check if a language pragma is redundant. We can't do this for all pragmas, 169 | -- but we do a best effort. 170 | isRedundant :: Module -> String -> Bool 171 | isRedundant m "ViewPatterns" = isRedundantViewPatterns m 172 | isRedundant m "BangPatterns" = isRedundantBangPatterns m 173 | isRedundant _ _ = False 174 | 175 | 176 | -------------------------------------------------------------------------------- 177 | -- | Check if the ViewPatterns language pragma is redundant. 178 | isRedundantViewPatterns :: Module -> Bool 179 | isRedundantViewPatterns = null . queryModule getViewPat 180 | where 181 | getViewPat :: GHC.Pat GHC.GhcPs -> [()] 182 | getViewPat = \case 183 | GHC.ViewPat{} -> [()] 184 | _ -> [] 185 | 186 | 187 | -------------------------------------------------------------------------------- 188 | -- | Check if the BangPatterns language pragma is redundant. 189 | isRedundantBangPatterns :: Module -> Bool 190 | isRedundantBangPatterns modul = 191 | (null $ queryModule getBangPat modul) && 192 | (null $ queryModule getMatchStrict modul) 193 | where 194 | getBangPat :: GHC.Pat GHC.GhcPs -> [()] 195 | getBangPat = \case 196 | GHC.BangPat{} -> [()] 197 | _ -> [] 198 | 199 | getMatchStrict :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> [()] 200 | getMatchStrict (GHC.Match _ ctx _ _) = case ctx of 201 | GHC.FunRhs _ _ GHC.SrcStrict _ -> [()] 202 | _ -> [] 203 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Step/ModuleHeader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Language.Haskell.Stylish.Step.ModuleHeader 5 | ( Config (..) 6 | , BreakWhere (..) 7 | , OpenBracket (..) 8 | , defaultConfig 9 | , step 10 | ) where 11 | 12 | 13 | -------------------------------------------------------------------------------- 14 | import Control.Applicative ((<|>)) 15 | import Control.Monad (guard, unless, when) 16 | import Data.Foldable (forM_) 17 | import Data.Maybe (fromMaybe, isJust, 18 | listToMaybe) 19 | import qualified GHC.Hs as GHC 20 | import qualified GHC.Types.SrcLoc as GHC 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | import Language.Haskell.Stylish.Comments 25 | import qualified Language.Haskell.Stylish.Editor as Editor 26 | import Language.Haskell.Stylish.GHC 27 | import Language.Haskell.Stylish.Module 28 | import Language.Haskell.Stylish.Ordering 29 | import Language.Haskell.Stylish.Printer 30 | import Language.Haskell.Stylish.Step 31 | import qualified Language.Haskell.Stylish.Step.Imports as Imports 32 | import Language.Haskell.Stylish.Util (flagEnds) 33 | import qualified GHC.Unit.Module.Warnings as GHC 34 | 35 | 36 | data Config = Config 37 | { indent :: Int 38 | , sort :: Bool 39 | , separateLists :: Bool 40 | , breakWhere :: BreakWhere 41 | , openBracket :: OpenBracket 42 | } 43 | 44 | data OpenBracket 45 | = SameLine 46 | | NextLine 47 | deriving (Eq, Show) 48 | 49 | data BreakWhere 50 | = Exports 51 | | Single 52 | | Inline 53 | | Always 54 | deriving (Eq, Show) 55 | 56 | defaultConfig :: Config 57 | defaultConfig = Config 58 | { indent = 4 59 | , sort = True 60 | , separateLists = True 61 | , breakWhere = Exports 62 | , openBracket = NextLine 63 | } 64 | 65 | step :: Maybe Int -> Config -> Step 66 | step maxCols = makeStep "Module header" . printModuleHeader maxCols 67 | 68 | printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines 69 | printModuleHeader maxCols conf ls lmodul = 70 | let modul = GHC.unLoc lmodul 71 | name = GHC.unLoc <$> GHC.hsmodName modul 72 | 73 | deprecMsg = GHC.hsmodDeprecMessage $ GHC.hsmodExt modul 74 | 75 | startLine = fromMaybe 1 $ moduleLine <|> 76 | (fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $ 77 | GHC.getLoc lmodul) 78 | 79 | endLine = fromMaybe 1 $ whereLine <|> 80 | (do 81 | loc <- GHC.getLocA <$> GHC.hsmodExports modul 82 | GHC.srcSpanEndLine <$> GHC.srcSpanToRealSrcSpan loc) 83 | 84 | keywordLine kw = do 85 | GHC.EpAnn {..} <- pure $ GHC.hsmodAnn $ GHC.hsmodExt modul 86 | case kw anns of 87 | GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) -> Just . GHC.srcSpanEndLine $ s 88 | _ -> Nothing 89 | 90 | moduleLine = keywordLine GHC.am_mod 91 | whereLine = keywordLine GHC.am_where 92 | 93 | commentOnLine l = listToMaybe $ do 94 | comment <- epAnnComments $ GHC.hsmodAnn $ GHC.hsmodExt modul 95 | guard $ GHC.srcSpanStartLine (GHC.epaLocationRealSrcSpan $ GHC.getLoc comment) == l 96 | pure comment 97 | 98 | moduleComment = moduleLine >>= commentOnLine 99 | whereComment = 100 | guard (whereLine /= moduleLine) >> whereLine >>= commentOnLine 101 | 102 | exportGroups = case GHC.hsmodExports modul of 103 | Nothing -> Nothing 104 | Just lexports -> Just $ doSort $ commentGroups 105 | (GHC.srcSpanToRealSrcSpan . GHC.getLocA) 106 | (GHC.unLoc lexports) 107 | (epAnnComments $ GHC.getLoc lexports) 108 | 109 | printedModuleHeader = runPrinter_ 110 | (PrinterConfig maxCols) 111 | (printHeader 112 | conf name deprecMsg exportGroups moduleComment whereComment) 113 | 114 | changes = Editor.changeLines 115 | (Editor.Block startLine endLine) 116 | (const printedModuleHeader) in 117 | 118 | Editor.apply changes ls 119 | where 120 | doSort = if sort conf then fmap (commentGroupSort compareLIE) else id 121 | 122 | printHeader 123 | :: Config 124 | -> Maybe GHC.ModuleName 125 | -> Maybe (GHC.LocatedP (GHC.WarningTxt GHC.GhcPs)) 126 | -> Maybe [CommentGroup (GHC.LIE GHC.GhcPs)] 127 | -> Maybe GHC.LEpaComment -- Comment attached to 'module' 128 | -> Maybe GHC.LEpaComment -- Comment attached to 'where' 129 | -> P () 130 | printHeader conf mbName mbDeprec mbExps mbModuleComment mbWhereComment = do 131 | forM_ mbName $ \name -> do 132 | putText "module" 133 | space 134 | putText (showOutputable name) 135 | 136 | forM_ mbDeprec \deprec -> do 137 | putText " " 138 | putText (showOutputable deprec) 139 | 140 | case mbExps of 141 | Nothing -> do 142 | when (isJust mbName) $ case breakWhere conf of 143 | Always -> do 144 | attachModuleComment 145 | newline 146 | spaces (indent conf) 147 | _ -> space 148 | putText "where" 149 | Just exports -> case breakWhere conf of 150 | Single | [] <- exports -> do 151 | printSingleLineExportList conf [] 152 | attachModuleComment 153 | Single | [egroup] <- exports 154 | , not (commentGroupHasComments egroup) 155 | , [(export, _)] <- cgItems egroup -> do 156 | printSingleLineExportList conf [export] 157 | attachModuleComment 158 | Inline | [] <- exports -> do 159 | printSingleLineExportList conf [] 160 | attachModuleComment 161 | Inline | [egroup] <- exports, not (commentGroupHasComments egroup) -> do 162 | wrapping 163 | (printSingleLineExportList conf $ map fst $ cgItems egroup) 164 | (do 165 | attachOpenBracket 166 | attachModuleComment 167 | printMultiLineExportList conf exports) 168 | _ -> do 169 | attachOpenBracket 170 | attachModuleComment 171 | printMultiLineExportList conf exports 172 | 173 | putMaybeLineComment $ GHC.unLoc <$> mbWhereComment 174 | where 175 | attachModuleComment = putMaybeLineComment $ GHC.unLoc <$> mbModuleComment 176 | 177 | attachOpenBracket 178 | | openBracket conf == SameLine = putText " (" 179 | | otherwise = pure () 180 | 181 | printSingleLineExportList 182 | :: Config -> [GHC.LIE GHC.GhcPs] -> P () 183 | printSingleLineExportList conf exports = do 184 | space >> putText "(" 185 | printExports exports 186 | putText ")" >> space >> putText "where" 187 | where 188 | printExports :: [GHC.LIE GHC.GhcPs] -> P () 189 | printExports = \case 190 | [] -> pure () 191 | [e] -> putExport conf e 192 | (e:es) -> putExport conf e >> comma >> space >> printExports es 193 | 194 | printMultiLineExportList 195 | :: Config 196 | -> [CommentGroup (GHC.LIE GHC.GhcPs)] 197 | -> P () 198 | printMultiLineExportList conf exports = do 199 | newline 200 | doIndent >> putText firstChar >> unless (null exports) space 201 | mapM_ printExport $ flagEnds exports 202 | when (null exports) $ newline >> doIndent 203 | putText ")" >> space >> putText "where" 204 | where 205 | printExport (CommentGroup {..}, firstGroup, _lastGroup) = do 206 | forM_ (flagEnds cgPrior) $ \(cmt, start, _end) -> do 207 | unless (firstGroup && start) $ space >> space 208 | putComment $ GHC.unLoc cmt 209 | newline >> doIndent 210 | 211 | forM_ (flagEnds cgItems) $ \((export, mbComment), start, _end) -> do 212 | if firstGroup && start then 213 | unless (null cgPrior) $ space >> space 214 | else 215 | comma >> space 216 | putExport conf export 217 | putMaybeLineComment $ GHC.unLoc <$> mbComment 218 | newline >> doIndent 219 | 220 | firstChar = case openBracket conf of 221 | SameLine -> " " 222 | NextLine -> "(" 223 | 224 | doIndent = spaces (indent conf) 225 | 226 | -- NOTE(jaspervdj): This code is almost the same as the import printing in 227 | -- 'Imports' and should be merged. 228 | putExport :: Config -> GHC.LIE GHC.GhcPs -> P () 229 | putExport conf = Imports.printImport (separateLists conf) . GHC.unLoc 230 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.LanguagePragmas.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.LanguagePragmas 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" 22 | [ testCase "case 01" case01 23 | , testCase "case 02" case02 24 | , testCase "case 03" case03 25 | , testCase "case 04" case04 26 | , testCase "case 05" case05 27 | , testCase "case 06" case06 28 | , testCase "case 07" case07 29 | , testCase "case 08" case08 30 | , testCase "case 09" case09 31 | , testCase "case 10" case10 32 | , testCase "case 11" case11 33 | , testCase "case 12" case12 34 | , testCase "case 13" case13 35 | , testCase "case 14" case14 36 | ] 37 | 38 | lANG :: String 39 | lANG = "LANGUAGE" 40 | 41 | -------------------------------------------------------------------------------- 42 | case01 :: Assertion 43 | case01 = assertSnippet 44 | (step (Just 80) Vertical True False lANG) 45 | [ "{-# LANGUAGE ViewPatterns #-}" 46 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 47 | , "{-# LANGUAGE ScopedTypeVariables #-}" 48 | , "module Main where" 49 | ] 50 | 51 | [ "{-# LANGUAGE ScopedTypeVariables #-}" 52 | , "{-# LANGUAGE TemplateHaskell #-}" 53 | , "{-# LANGUAGE ViewPatterns #-}" 54 | , "module Main where" 55 | ] 56 | 57 | 58 | -------------------------------------------------------------------------------- 59 | case02 :: Assertion 60 | case02 = assertSnippet 61 | (step (Just 80) Vertical True True lANG) 62 | [ "{-# LANGUAGE BangPatterns #-}" 63 | , "{-# LANGUAGE ViewPatterns #-}" 64 | , "module Main where" 65 | , "increment ((+ 1) -> x) = x" 66 | ] 67 | 68 | [ "{-# LANGUAGE ViewPatterns #-}" 69 | , "module Main where" 70 | , "increment ((+ 1) -> x) = x" 71 | ] 72 | 73 | 74 | -------------------------------------------------------------------------------- 75 | case03 :: Assertion 76 | case03 = assertSnippet 77 | (step (Just 80) Vertical True True lANG) 78 | [ "{-# LANGUAGE BangPatterns #-}" 79 | , "{-# LANGUAGE ViewPatterns #-}" 80 | , "module Main where" 81 | , "increment x = case x of !_ -> x + 1" 82 | ] 83 | 84 | [ "{-# LANGUAGE BangPatterns #-}" 85 | , "module Main where" 86 | , "increment x = case x of !_ -> x + 1" 87 | ] 88 | 89 | 90 | -------------------------------------------------------------------------------- 91 | case04 :: Assertion 92 | case04 = assertSnippet 93 | (step (Just 80) Compact True False lANG) 94 | [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," 95 | , " TemplateHaskell #-}" 96 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 97 | ] 98 | 99 | [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ 100 | "TemplateHaskell," 101 | , " TypeOperators, ViewPatterns #-}" 102 | ] 103 | 104 | 105 | -------------------------------------------------------------------------------- 106 | case05 :: Assertion 107 | case05 = assertSnippet 108 | (step (Just 80) Vertical True False lANG) 109 | [ "{-# LANGUAGE CPP #-}" 110 | , "" 111 | , "#if __GLASGOW_HASKELL__ >= 702" 112 | , "{-# LANGUAGE Trustworthy #-}" 113 | , "#endif" 114 | ] 115 | 116 | [ "{-# LANGUAGE CPP #-}" 117 | , "" 118 | , "#if __GLASGOW_HASKELL__ >= 702" 119 | , "{-# LANGUAGE Trustworthy #-}" 120 | , "#endif" 121 | ] 122 | 123 | 124 | -------------------------------------------------------------------------------- 125 | case06 :: Assertion 126 | case06 = assertSnippet 127 | (step (Just 80) CompactLine True False lANG) 128 | [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," 129 | , " TemplateHaskell #-}" 130 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 131 | ] 132 | [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ 133 | "TemplateHaskell #-}" 134 | , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" 135 | ] 136 | 137 | -------------------------------------------------------------------------------- 138 | case07 :: Assertion 139 | case07 = assertSnippet 140 | (step (Just 80) Vertical False False lANG) 141 | [ "{-# LANGUAGE ViewPatterns #-}" 142 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 143 | , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" 144 | , "module Main where" 145 | ] 146 | 147 | [ "{-# LANGUAGE NoImplicitPrelude #-}" 148 | , "{-# LANGUAGE ScopedTypeVariables #-}" 149 | , "{-# LANGUAGE TemplateHaskell #-}" 150 | , "{-# LANGUAGE ViewPatterns #-}" 151 | , "module Main where" 152 | ] 153 | 154 | 155 | -------------------------------------------------------------------------------- 156 | case08 :: Assertion 157 | case08 = assertSnippet 158 | (step (Just 80) CompactLine False False lANG) 159 | [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," 160 | , " TemplateHaskell #-}" 161 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 162 | ] 163 | [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ 164 | "TemplateHaskell #-}" 165 | , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" 166 | ] 167 | 168 | 169 | -------------------------------------------------------------------------------- 170 | case09 :: Assertion 171 | case09 = assertSnippet 172 | (step (Just 80) Compact True False lANG) 173 | [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ 174 | "TypeApplications" 175 | , " #-}" 176 | ] 177 | [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," 178 | , " TypeApplications #-}" 179 | ] 180 | 181 | -------------------------------------------------------------------------------- 182 | case10 :: Assertion 183 | case10 = assertSnippet 184 | (step (Just 80) Compact True False lANG) 185 | [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," 186 | , " TypeApplications #-}" 187 | ] 188 | [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ 189 | "TypeApplications #-}" 190 | ] 191 | 192 | -------------------------------------------------------------------------------- 193 | case11 :: Assertion 194 | case11 = assertSnippet 195 | (step (Just 80) Vertical False False "language") 196 | [ "{-# LANGUAGE ViewPatterns #-}" 197 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 198 | , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" 199 | , "module Main where" 200 | ] 201 | 202 | [ "{-# language NoImplicitPrelude #-}" 203 | , "{-# language ScopedTypeVariables #-}" 204 | , "{-# language TemplateHaskell #-}" 205 | , "{-# language ViewPatterns #-}" 206 | , "module Main where" 207 | ] 208 | 209 | 210 | -------------------------------------------------------------------------------- 211 | case12 :: Assertion 212 | case12 = assertSnippet 213 | (step Nothing Compact False False "language") 214 | [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" 215 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 216 | , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" 217 | , "module Main where" 218 | ] 219 | 220 | [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" 221 | , "module Main where" 222 | ] 223 | 224 | 225 | -------------------------------------------------------------------------------- 226 | case13 :: Assertion 227 | case13 = assertSnippet 228 | (step Nothing Vertical True True lANG) input input 229 | where 230 | input = 231 | [ "{-# LANGUAGE BangPatterns #-}" 232 | , "{-# LANGUAGE DeriveFunctor #-}" 233 | , "" 234 | , "main = let !x = 1 + 1 in print x" 235 | ] 236 | 237 | -------------------------------------------------------------------------------- 238 | case14 :: Assertion 239 | case14 = assertSnippet (step Nothing VerticalCompact False False "language") 240 | [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" 241 | , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" 242 | , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" 243 | , "module Main where" 244 | ] 245 | [ "{-# language" 246 | , " NoImplicitPrelude" 247 | , " , OverloadedStrings" 248 | , " , ScopedTypeVariables" 249 | , " , TemplateHaskell" 250 | , " , ViewPatterns" 251 | , " #-}" 252 | , "module Main where" 253 | ] 254 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Util.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | module Language.Haskell.Stylish.Util 5 | ( indent 6 | , padRight 7 | , everything 8 | , trimLeft 9 | , trimRight 10 | , wrap 11 | , wrapRest 12 | , wrapMaybe 13 | , wrapRestMaybe 14 | 15 | -- * Extra list functions 16 | , withHead 17 | , withInit 18 | , withTail 19 | , withLast 20 | , flagEnds 21 | 22 | , traceOutputable 23 | , traceOutputableM 24 | 25 | , unguardedRhsBody 26 | , rhsBody 27 | 28 | , getGuards 29 | ) where 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | import Data.Char (isSpace) 34 | import Data.Data (Data) 35 | import qualified Data.Generics as G 36 | import Data.Maybe (maybeToList) 37 | import Data.Typeable (cast) 38 | import Debug.Trace (trace) 39 | import qualified GHC.Hs as Hs 40 | import qualified GHC.Types.SrcLoc as GHC 41 | import qualified GHC.Utils.Outputable as GHC 42 | 43 | 44 | -------------------------------------------------------------------------------- 45 | import Language.Haskell.Stylish.GHC (showOutputable) 46 | import Language.Haskell.Stylish.Step 47 | 48 | 49 | -------------------------------------------------------------------------------- 50 | indent :: Int -> String -> String 51 | indent len = (indentPrefix len ++) 52 | 53 | 54 | -------------------------------------------------------------------------------- 55 | indentPrefix :: Int -> String 56 | indentPrefix = (`replicate` ' ') 57 | 58 | 59 | -------------------------------------------------------------------------------- 60 | padRight :: Int -> String -> String 61 | padRight len str = str ++ replicate (len - length str) ' ' 62 | 63 | 64 | -------------------------------------------------------------------------------- 65 | everything :: (Data a, Data b) => a -> [b] 66 | everything = G.everything (++) (maybeToList . cast) 67 | 68 | 69 | -------------------------------------------------------------------------------- 70 | {- 71 | infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))] 72 | infoPoints = fmap (helper . S.getLoc) 73 | where 74 | helper :: S.SrcSpan -> ((Int, Int), (Int, Int)) 75 | helper (S.RealSrcSpan s) = do 76 | let 77 | start = S.realSrcSpanStart s 78 | end = S.realSrcSpanEnd s 79 | ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end)) 80 | helper _ = ((-1,-1), (-1,-1)) 81 | -} 82 | 83 | -------------------------------------------------------------------------------- 84 | trimLeft :: String -> String 85 | trimLeft = dropWhile isSpace 86 | 87 | 88 | -------------------------------------------------------------------------------- 89 | trimRight :: String -> String 90 | trimRight = reverse . trimLeft . reverse 91 | 92 | 93 | -------------------------------------------------------------------------------- 94 | wrap :: Int -- ^ Maximum line width 95 | -> String -- ^ Leading string 96 | -> Int -- ^ Indentation 97 | -> [String] -- ^ Strings to add/wrap 98 | -> Lines -- ^ Resulting lines 99 | wrap maxWidth leading ind = wrap' leading 100 | where 101 | wrap' ss [] = [ss] 102 | wrap' ss (str:strs) 103 | | overflows ss str = 104 | ss : wrapRest maxWidth ind (str:strs) 105 | | otherwise = wrap' (ss ++ " " ++ str) strs 106 | 107 | overflows ss str = length ss > maxWidth || 108 | ((length ss + length str) >= maxWidth && ind + length str <= maxWidth) 109 | 110 | 111 | -------------------------------------------------------------------------------- 112 | wrapMaybe :: Maybe Int -- ^ Maximum line width (maybe) 113 | -> String -- ^ Leading string 114 | -> Int -- ^ Indentation 115 | -> [String] -- ^ Strings to add/wrap 116 | -> Lines -- ^ Resulting lines 117 | wrapMaybe (Just maxWidth) = wrap maxWidth 118 | wrapMaybe Nothing = noWrap 119 | 120 | 121 | -------------------------------------------------------------------------------- 122 | noWrap :: String -- ^ Leading string 123 | -> Int -- ^ Indentation 124 | -> [String] -- ^ Strings to add 125 | -> Lines -- ^ Resulting lines 126 | noWrap leading _ind = noWrap' leading 127 | where 128 | noWrap' ss [] = [ss] 129 | noWrap' ss (str:strs) = noWrap' (ss ++ " " ++ str) strs 130 | 131 | 132 | -------------------------------------------------------------------------------- 133 | wrapRest :: Int 134 | -> Int 135 | -> [String] 136 | -> Lines 137 | wrapRest maxWidth ind = reverse . wrapRest' [] "" 138 | where 139 | wrapRest' ls ss [] 140 | | null ss = ls 141 | | otherwise = ss:ls 142 | wrapRest' ls ss (str:strs) 143 | | null ss = wrapRest' ls (indent ind str) strs 144 | | overflows ss str = wrapRest' (ss:ls) "" (str:strs) 145 | | otherwise = wrapRest' ls (ss ++ " " ++ str) strs 146 | 147 | overflows ss str = (length ss + length str + 1) >= maxWidth 148 | 149 | 150 | -------------------------------------------------------------------------------- 151 | wrapRestMaybe :: Maybe Int 152 | -> Int 153 | -> [String] 154 | -> Lines 155 | wrapRestMaybe (Just maxWidth) = wrapRest maxWidth 156 | wrapRestMaybe Nothing = noWrapRest 157 | 158 | 159 | -------------------------------------------------------------------------------- 160 | noWrapRest :: Int 161 | -> [String] 162 | -> Lines 163 | noWrapRest ind = reverse . noWrapRest' [] "" 164 | where 165 | noWrapRest' ls ss [] 166 | | null ss = ls 167 | | otherwise = ss:ls 168 | noWrapRest' ls ss (str:strs) 169 | | null ss = noWrapRest' ls (indent ind str) strs 170 | | otherwise = noWrapRest' ls (ss ++ " " ++ str) strs 171 | 172 | 173 | -------------------------------------------------------------------------------- 174 | withHead :: (a -> a) -> [a] -> [a] 175 | withHead _ [] = [] 176 | withHead f (x : xs) = f x : xs 177 | 178 | 179 | -------------------------------------------------------------------------------- 180 | withLast :: (a -> a) -> [a] -> [a] 181 | withLast _ [] = [] 182 | withLast f [x] = [f x] 183 | withLast f (x : xs) = x : withLast f xs 184 | 185 | 186 | -------------------------------------------------------------------------------- 187 | withInit :: (a -> a) -> [a] -> [a] 188 | withInit _ [] = [] 189 | withInit _ [x] = [x] 190 | withInit f (x : xs) = f x : withInit f xs 191 | 192 | 193 | -------------------------------------------------------------------------------- 194 | withTail :: (a -> a) -> [a] -> [a] 195 | withTail _ [] = [] 196 | withTail f (x : xs) = x : map f xs 197 | 198 | 199 | 200 | -------------------------------------------------------------------------------- 201 | -- | Utility for traversing through a list and knowing when you're at the 202 | -- first and last element. 203 | flagEnds :: [a] -> [(a, Bool, Bool)] 204 | flagEnds = \case 205 | [] -> [] 206 | [x] -> [(x, True, True)] 207 | x : y : zs -> (x, True, False) : go (y : zs) 208 | where 209 | go (x : y : zs) = (x, False, False) : go (y : zs) 210 | go [x] = [(x, False, True)] 211 | go [] = [] 212 | 213 | 214 | -------------------------------------------------------------------------------- 215 | traceOutputable :: GHC.Outputable a => String -> a -> b -> b 216 | traceOutputable title x = 217 | trace (title ++ ": " ++ (showOutputable x)) 218 | 219 | 220 | -------------------------------------------------------------------------------- 221 | traceOutputableM :: (GHC.Outputable a, Monad m) => String -> a -> m () 222 | traceOutputableM title x = traceOutputable title x $ pure () 223 | 224 | 225 | -------------------------------------------------------------------------------- 226 | -- Utility: grab the body out of guarded RHSs if it's a single unguarded one. 227 | unguardedRhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a 228 | unguardedRhsBody (Hs.GRHSs _ [grhs] _) 229 | | Hs.GRHS _ [] body <- GHC.unLoc grhs = Just body 230 | unguardedRhsBody _ = Nothing 231 | 232 | 233 | -- Utility: grab the body out of guarded RHSs 234 | rhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a 235 | rhsBody (Hs.GRHSs _ [grhs] _) 236 | | Hs.GRHS _ _ body <- GHC.unLoc grhs = Just body 237 | rhsBody _ = Nothing 238 | 239 | 240 | -------------------------------------------------------------------------------- 241 | -- get guards in a guarded rhs of a Match 242 | getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] 243 | getGuards (Hs.Match _ _ _ grhss) = 244 | let 245 | lgrhs = getLocGRHS grhss -- [] 246 | grhs = map GHC.unLoc lgrhs 247 | in 248 | concatMap getGuardLStmts grhs 249 | 250 | 251 | getLocGRHS :: Hs.GRHSs Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.LGRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] 252 | getLocGRHS (Hs.GRHSs _ guardeds _) = guardeds 253 | 254 | 255 | getGuardLStmts :: Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] 256 | getGuardLStmts (Hs.GRHS _ guards _) = guards 257 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Config/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Language.Haskell.Stylish.Config.Tests 3 | ( tests 4 | ) where 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | import qualified Data.Aeson.Types as Aeson 9 | import qualified Data.ByteString.Lazy.Char8 as BL8 10 | import qualified Data.Set as Set 11 | import qualified Data.YAML.Aeson as Yaml 12 | import System.Directory 13 | import Test.Framework (Test, testGroup) 14 | import Test.Framework.Providers.HUnit (testCase) 15 | import Test.HUnit (Assertion, (@?=)) 16 | 17 | 18 | -------------------------------------------------------------------------------- 19 | import Language.Haskell.Stylish.Config 20 | import Language.Haskell.Stylish.Tests.Util 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | tests :: Test 25 | tests = testGroup "Language.Haskell.Stylish.Config" 26 | [ testCase "Extensions extracted correctly from .cabal file" 27 | testExtensionsFromDotCabal 28 | , testCase "Extensions extracted correctly from .stylish-haskell.yaml file" 29 | testExtensionsFromDotStylish 30 | , testCase "Extensions extracted correctly from .stylish-haskell.yaml and .cabal files" 31 | testExtensionsFromBoth 32 | , testCase "NoXyz extensions from .stylish-haskell.yaml file" 33 | testStylishNoXyz 34 | , testCase "NoXyz extensions from .cabal file" 35 | testCabalNoXyz 36 | , testCase "Correctly read .stylish-haskell.yaml file with default max column number" 37 | testDefaultColumns 38 | , testCase "Correctly read .stylish-haskell.yaml file with specified max column number" 39 | testSpecifiedColumns 40 | , testCase "Correctly read .stylish-haskell.yaml file with no max column number" 41 | testNoColumns 42 | , testCase "Backwards-compatible align options" 43 | testBoolSimpleAlign 44 | ] 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- 49 | type ExtensionName = String 50 | 51 | data ConfigFile = ConfigFile 52 | { fileName :: FilePath 53 | , contents :: String 54 | , extensions :: [ExtensionName] 55 | } 56 | 57 | stylishCfg :: ([ExtensionName] -> String) -> [ExtensionName] -> ConfigFile 58 | stylishCfg template exts = ConfigFile 59 | { fileName = ".stylish-haskell.yaml" 60 | , contents = template exts 61 | , extensions = exts 62 | } 63 | 64 | cabalCfg :: ([ExtensionName] -> [ExtensionName] -> String) -> 65 | [ExtensionName] -> [ExtensionName] -> ConfigFile 66 | cabalCfg template exts1 exts2 = ConfigFile 67 | { fileName = "test.cabal" 68 | , contents = template exts1 exts2 69 | , extensions = exts1 ++ exts2 70 | } 71 | 72 | 73 | -------------------------------------------------------------------------------- 74 | testExtensions :: [ConfigFile] -> Assertion 75 | testExtensions cfgFiles = do 76 | cfg' <- createFilesAndGetConfig cfgFiles 77 | let expected = Set.fromList (concatMap extensions cfgFiles) 78 | actual = Set.fromList (configLanguageExtensions cfg') 79 | actual @?= expected 80 | 81 | testColumns :: Maybe Int -> [ConfigFile] -> Assertion 82 | testColumns expected cfgFiles = do 83 | cfg' <- createFilesAndGetConfig cfgFiles 84 | let actual = configColumns cfg' 85 | actual @?= expected 86 | 87 | 88 | -------------------------------------------------------------------------------- 89 | -- | Put an example config files (.cabal/.stylish-haskell.yaml/both) 90 | -- into the current directory and extract extensions from it. 91 | createFilesAndGetConfig :: [ConfigFile] -> IO Config 92 | createFilesAndGetConfig files = withTestDirTree $ do 93 | mapM_ (\ConfigFile{..} -> writeFile fileName contents) files 94 | -- create an empty directory and change into it 95 | createDirectory "src" 96 | setCurrentDirectory "src" 97 | -- from that directory read the config file and extract extensions 98 | -- to make sure the search for .cabal file works 99 | loadConfig (const (pure ())) SearchFromCurrentDirectory 100 | 101 | 102 | -------------------------------------------------------------------------------- 103 | testExtensionsFromDotCabal :: Assertion 104 | testExtensionsFromDotCabal = testExtensions 105 | [ cabalCfg dotCabal ["ScopedTypeVariables"] ["DataKinds"] ] 106 | 107 | -------------------------------------------------------------------------------- 108 | testExtensionsFromDotStylish :: Assertion 109 | testExtensionsFromDotStylish = testExtensions 110 | [ stylishCfg dotStylish ["TemplateHaskell", "QuasiQuotes"] ] 111 | 112 | -------------------------------------------------------------------------------- 113 | testExtensionsFromBoth :: Assertion 114 | testExtensionsFromBoth = testExtensions 115 | [ cabalCfg dotCabal ["ScopedTypeVariables"] ["DataKinds"] 116 | , stylishCfg dotStylish ["TemplateHaskell", "QuasiQuotes"] 117 | ] 118 | 119 | -------------------------------------------------------------------------------- 120 | testStylishNoXyz :: Assertion 121 | testStylishNoXyz = testExtensions 122 | [ stylishCfg dotStylish ["NoStarIsType", "NoTypeOperators"] ] 123 | 124 | -------------------------------------------------------------------------------- 125 | testCabalNoXyz :: Assertion 126 | testCabalNoXyz = testExtensions 127 | [ cabalCfg dotCabal ["NoStarIsType"] ["NoTypeOperators"] ] 128 | 129 | 130 | -------------------------------------------------------------------------------- 131 | testSpecifiedColumns :: Assertion 132 | testSpecifiedColumns = testColumns (Just 110) 133 | [ stylishCfg dotStylish [] ] 134 | 135 | 136 | -------------------------------------------------------------------------------- 137 | testDefaultColumns :: Assertion 138 | testDefaultColumns = testColumns (Just 80) 139 | [ stylishCfg dotStylish2 ["DataKinds"] ] 140 | 141 | 142 | -------------------------------------------------------------------------------- 143 | testNoColumns :: Assertion 144 | testNoColumns = testColumns Nothing 145 | [ stylishCfg dotStylish3 ["DataKinds"] ] 146 | 147 | 148 | -------------------------------------------------------------------------------- 149 | testBoolSimpleAlign :: Assertion 150 | testBoolSimpleAlign = do 151 | Right val <- pure $ Yaml.decode1 $ BL8.pack config 152 | Aeson.Success conf <- pure $ Aeson.parse parseConfig val 153 | length (configSteps conf) @?= 1 154 | where 155 | config = unlines 156 | [ "steps:" 157 | , " - simple_align:" 158 | , " cases: true" 159 | , " top_level_patterns: always" 160 | , " records: false" 161 | ] 162 | 163 | 164 | -- | Example cabal file borrowed from 165 | -- https://www.haskell.org/cabal/users-guide/developing-packages.html 166 | -- with some default-extensions added 167 | dotCabal :: [ExtensionName] -> [ExtensionName] -> String 168 | dotCabal exts1 exts2 = unlines $ 169 | [ "name: TestPackage" 170 | , "version: 0.0" 171 | , "synopsis: Package with library and two programs" 172 | , "license: BSD3" 173 | , "author: Angela Author" 174 | , "build-type: Simple" 175 | , "cabal-version: >= 1.10" 176 | , "" 177 | , "library" 178 | , " build-depends: HUnit" 179 | , " exposed-modules: A, B, C" 180 | , " default-extensions:" 181 | ] ++ 182 | map (" " ++) exts1 183 | ++ 184 | [ "" 185 | , "executable program1" 186 | , " main-is: Main.hs" 187 | , " hs-source-dirs: prog1" 188 | , " other-modules: A, B" 189 | , " default-extensions:" 190 | ] ++ 191 | map (" " ++) exts2 192 | 193 | -- | Example .stylish-haskell.yaml 194 | dotStylish :: [ExtensionName] -> String 195 | dotStylish exts = unlines $ 196 | [ "steps:" 197 | , " - imports:" 198 | , " align: none" 199 | , " list_align: after_alias" 200 | , " long_list_align: inline" 201 | , " separate_lists: true" 202 | , " - language_pragmas:" 203 | , " style: vertical" 204 | , " align: false" 205 | , " remove_redundant: true" 206 | , " - trailing_whitespace: {}" 207 | , " - records:" 208 | , " equals: \"same_line\"" 209 | , " first_field: \"indent 2\"" 210 | , " field_comment: 2" 211 | , " deriving: 4" 212 | , " via: \"indent 2\"" 213 | , "columns: 110" 214 | , "language_extensions:" 215 | ] ++ 216 | map (" - " ++) exts 217 | 218 | -- | Example .stylish-haskell.yaml 219 | dotStylish2 :: [ExtensionName] -> String 220 | dotStylish2 exts = unlines $ 221 | [ "steps:" 222 | , " - imports:" 223 | , " align: none" 224 | , " list_align: after_alias" 225 | , " long_list_align: inline" 226 | , " separate_lists: true" 227 | , " - language_pragmas:" 228 | , " style: vertical" 229 | , " align: false" 230 | , " remove_redundant: true" 231 | , " - trailing_whitespace: {}" 232 | , "language_extensions:" 233 | ] ++ 234 | map (" - " ++) exts 235 | 236 | 237 | -- | Example .stylish-haskell.yaml 238 | dotStylish3 :: [ExtensionName] -> String 239 | dotStylish3 exts = unlines $ 240 | [ "steps:" 241 | , " - imports:" 242 | , " align: none" 243 | , " list_align: after_alias" 244 | , " long_list_align: inline" 245 | , " separate_lists: true" 246 | , " - language_pragmas:" 247 | , " style: vertical" 248 | , " align: false" 249 | , " remove_redundant: true" 250 | , " - trailing_whitespace: {}" 251 | , "columns: null" 252 | , "language_extensions:" 253 | ] ++ 254 | map (" - " ++) exts 255 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Haskell.Stylish.Step.SimpleAlign.Tests 4 | ( tests 5 | ) where 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | import Test.Framework (Test, testGroup) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.HUnit (Assertion) 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | import Language.Haskell.Stylish.Step.SimpleAlign 16 | import Language.Haskell.Stylish.Tests.Util 17 | 18 | 19 | -------------------------------------------------------------------------------- 20 | tests :: Test 21 | tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" 22 | [ testCase "case 01" case01 23 | , testCase "case 02" case02 24 | , testCase "case 03" case03 25 | , testCase "case 04" case04 26 | , testCase "case 05" case05 27 | , testCase "case 06" case06 28 | , testCase "case 07" case07 29 | , testCase "case 08" case08 30 | , testCase "case 09" case09 31 | , testCase "case 10" case10 32 | , testCase "case 11" case11 33 | , testCase "case 12" case12 34 | , testCase "case 13" case13 35 | , testCase "case 13b" case13b 36 | , testCase "case 14" case14 37 | , testCase "case 15" case15 38 | , testCase "case 16" case16 39 | , testCase "case 17" case17 40 | ] 41 | 42 | 43 | -------------------------------------------------------------------------------- 44 | case01 :: Assertion 45 | case01 = assertSnippet (step (Just 80) defaultConfig) 46 | [ "eitherToMaybe e = case e of" 47 | , " Left _ -> Nothing" 48 | , " Right x -> Just x" 49 | ] 50 | [ "eitherToMaybe e = case e of" 51 | , " Left _ -> Nothing" 52 | , " Right x -> Just x" 53 | ] 54 | 55 | 56 | -------------------------------------------------------------------------------- 57 | case02 :: Assertion 58 | case02 = assertSnippet (step (Just 80) defaultConfig) 59 | [ "eitherToMaybe (Left _) = Nothing" 60 | , "eitherToMaybe (Right x) = Just x" 61 | ] 62 | [ "eitherToMaybe (Left _) = Nothing" 63 | , "eitherToMaybe (Right x) = Just x" 64 | ] 65 | 66 | 67 | -------------------------------------------------------------------------------- 68 | case03 :: Assertion 69 | case03 = assertSnippet (step (Just 80) defaultConfig) 70 | [ "heady def [] = def" 71 | , "heady _ (x : _) = x" 72 | ] 73 | [ "heady def [] = def" 74 | , "heady _ (x : _) = x" 75 | ] 76 | 77 | 78 | -------------------------------------------------------------------------------- 79 | case04 :: Assertion 80 | case04 = assertSnippet (step (Just 80) defaultConfig) 81 | [ "data Foo = Foo" 82 | , " { foo :: Int" 83 | , " , barqux :: String" 84 | , " } deriving (Show)" 85 | ] 86 | [ "data Foo = Foo" 87 | , " { foo :: Int" 88 | , " , barqux :: String" 89 | , " } deriving (Show)" 90 | ] 91 | 92 | 93 | -------------------------------------------------------------------------------- 94 | case05 :: Assertion 95 | case05 = assertSnippet (step (Just 80) defaultConfig) input input 96 | where 97 | -- Don't attempt to align this since a field spans multiple lines 98 | input = 99 | [ "data Foo = Foo" 100 | , " { foo :: Int" 101 | , " , barqux" 102 | , " :: String" 103 | , " } deriving (Show)" 104 | ] 105 | 106 | 107 | -------------------------------------------------------------------------------- 108 | case06 :: Assertion 109 | case06 = assertSnippet 110 | -- 22 max columns is /just/ enough to align this stuff. 111 | (step (Just 22) defaultConfig) 112 | [ "data Foo = Foo" 113 | , " { foo :: String" 114 | , " , barqux :: Int" 115 | , " }" 116 | ] 117 | [ "data Foo = Foo" 118 | , " { foo :: String" 119 | , " , barqux :: Int" 120 | , " }" 121 | ] 122 | 123 | 124 | -------------------------------------------------------------------------------- 125 | case07 :: Assertion 126 | case07 = assertSnippet 127 | -- 21 max columns is /just NOT/ enough to align this stuff. 128 | (step (Just 21) defaultConfig) 129 | [ "data Foo = Foo" 130 | , " { foo :: String" 131 | , " , barqux :: Int" 132 | , " }" 133 | ] 134 | [ "data Foo = Foo" 135 | , " { foo :: String" 136 | , " , barqux :: Int" 137 | , " }" 138 | ] 139 | 140 | 141 | -------------------------------------------------------------------------------- 142 | case08 :: Assertion 143 | case08 = assertSnippet (step (Just 80) defaultConfig) 144 | [ "canDrink mbAge = case mbAge of" 145 | , " Just age | age > 18 -> True" 146 | , " _ -> False" 147 | ] 148 | [ "canDrink mbAge = case mbAge of" 149 | , " Just age | age > 18 -> True" 150 | , " _ -> False" 151 | ] 152 | 153 | 154 | -------------------------------------------------------------------------------- 155 | case09 :: Assertion 156 | case09 = assertSnippet (step Nothing defaultConfig) 157 | [ "data Foo = Foo" 158 | , " { foo :: String" 159 | , " , barqux :: Int" 160 | , " }" 161 | ] 162 | [ "data Foo = Foo" 163 | , " { foo :: String" 164 | , " , barqux :: Int" 165 | , " }" 166 | ] 167 | 168 | 169 | -------------------------------------------------------------------------------- 170 | case10 :: Assertion 171 | case10 = assertSnippet (step Nothing defaultConfig) 172 | [ "padQual = case align' of" 173 | , " Global -> True" 174 | , " File -> fileAlign" 175 | , " Group -> anyQual" 176 | ] 177 | [ "padQual = case align' of" 178 | , " Global -> True" 179 | , " File -> fileAlign" 180 | , " Group -> anyQual" 181 | ] 182 | 183 | 184 | -------------------------------------------------------------------------------- 185 | case11 :: Assertion 186 | case11 = assertSnippet (step Nothing defaultConfig) 187 | [ "data Foo = Foo" 188 | , " { foo :: String" 189 | , " , barqux :: !Int" 190 | , " }" 191 | ] 192 | [ "data Foo = Foo" 193 | , " { foo :: String" 194 | , " , barqux :: !Int" 195 | , " }" 196 | ] 197 | 198 | 199 | -------------------------------------------------------------------------------- 200 | case12 :: Assertion 201 | case12 = assertSnippet (step Nothing defaultConfig { cCases = Never }) input input 202 | where 203 | input = 204 | [ "case x of" 205 | , " Just y -> 1" 206 | , " Nothing -> 2" 207 | ] 208 | 209 | 210 | -------------------------------------------------------------------------------- 211 | case13 :: Assertion 212 | case13 = assertSnippet (step Nothing defaultConfig) 213 | [ "cond n = if" 214 | , " | n < 10, x <- 1 -> x" 215 | , " | otherwise -> 2" 216 | ] 217 | [ "cond n = if" 218 | , " | n < 10, x <- 1 -> x" 219 | , " | otherwise -> 2" 220 | ] 221 | 222 | case13b :: Assertion 223 | case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) 224 | [ "cond n = if" 225 | , " | n < 10, x <- 1 -> x" 226 | , " | otherwise -> 2" 227 | ] 228 | [ "cond n = if" 229 | , " | n < 10, x <- 1 -> x" 230 | , " | otherwise -> 2" 231 | ] 232 | 233 | 234 | -------------------------------------------------------------------------------- 235 | case14 :: Assertion 236 | case14 = assertSnippet (step (Just 80) defaultConfig { cCases = Adjacent }) 237 | [ "catch e = case e of" 238 | , " Left GoodError -> 1" 239 | , " Left BadError -> 2" 240 | , " -- otherwise" 241 | , " Right [] -> 0" 242 | , " Right (x:_) -> x" 243 | ] 244 | [ "catch e = case e of" 245 | , " Left GoodError -> 1" 246 | , " Left BadError -> 2" 247 | , " -- otherwise" 248 | , " Right [] -> 0" 249 | , " Right (x:_) -> x" 250 | ] 251 | 252 | 253 | -------------------------------------------------------------------------------- 254 | case15 :: Assertion 255 | case15 = assertSnippet (step (Just 80) defaultConfig { cTopLevelPatterns = Adjacent }) 256 | [ "catch (Left GoodError) = 1" 257 | , "catch (Left BadError) = 2" 258 | , "-- otherwise" 259 | , "catch (Right []) = 0" 260 | , "catch (Right (x:_)) = x" 261 | ] 262 | [ "catch (Left GoodError) = 1" 263 | , "catch (Left BadError) = 2" 264 | , "-- otherwise" 265 | , "catch (Right []) = 0" 266 | , "catch (Right (x:_)) = x" 267 | ] 268 | 269 | 270 | -------------------------------------------------------------------------------- 271 | case16 :: Assertion 272 | case16 = assertSnippet (step (Just 80) defaultConfig { cRecords = Adjacent }) 273 | [ "data Foo = Foo" 274 | , " { foo :: Int" 275 | , " , foo2 :: String" 276 | , " -- a comment" 277 | , " , barqux :: String" 278 | , " , baz :: String" 279 | , " , baz2 :: Bool" 280 | , " } deriving (Show)" 281 | ] 282 | [ "data Foo = Foo" 283 | , " { foo :: Int" 284 | , " , foo2 :: String" 285 | , " -- a comment" 286 | , " , barqux :: String" 287 | , " , baz :: String" 288 | , " , baz2 :: Bool" 289 | , " } deriving (Show)" 290 | ] 291 | 292 | 293 | -------------------------------------------------------------------------------- 294 | case17 :: Assertion 295 | case17 = assertSnippet (step Nothing defaultConfig { cMultiWayIf = Adjacent }) 296 | [ "cond n = if" 297 | , " | n < 10, x <- 1 -> x" 298 | , " -- comment" 299 | , " | otherwise -> 2" 300 | ] 301 | [ "cond n = if" 302 | , " | n < 10, x <- 1 -> x" 303 | , " -- comment" 304 | , " | otherwise -> 2" 305 | ] 306 | -------------------------------------------------------------------------------- /tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | Tests contributed by Felix Mulder as part of 3 | -- . 4 | {-# LANGUAGE OverloadedLists #-} 5 | module Language.Haskell.Stylish.Step.Imports.FelixTests 6 | ( tests 7 | ) where 8 | 9 | 10 | -------------------------------------------------------------------------------- 11 | import Prelude hiding (lines) 12 | import Test.Framework (Test, testGroup) 13 | import Test.Framework.Providers.HUnit (testCase) 14 | import Test.HUnit (Assertion) 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | import Language.Haskell.Stylish.Step.Imports 19 | import Language.Haskell.Stylish.Tests.Util (assertSnippet) 20 | 21 | 22 | -------------------------------------------------------------------------------- 23 | tests :: Test 24 | tests = testGroup "Language.Haskell.Stylish.Step.Imports.FelixTests" 25 | [ testCase "Hello world" ex0 26 | , testCase "Sorted simple" ex1 27 | , testCase "Sorted import lists" ex2 28 | , testCase "Sorted import lists and import decls" ex3 29 | , testCase "Import constructor all" ex4 30 | , testCase "Import constructor specific" ex5 31 | , testCase "Import constructor specific sorted" ex6 32 | , testCase "Imports step does not change rest of file" ex7 33 | , testCase "Imports respect groups" ex8 34 | , testCase "Imports respects whitespace between groups" ex9 35 | , testCase "Doesn't add extra space after 'hiding'" ex10 36 | , testCase "Should be able to format symbolic imports" ex11 37 | , testCase "Able to merge equivalent imports" ex12 38 | , testCase "Obeys max columns setting" ex13 39 | , testCase "Obeys max columns setting with two in each" ex14 40 | , testCase "Respects multiple groups" ex15 41 | , testCase "Doesn't delete nullary imports" ex16 42 | ] 43 | 44 | 45 | -------------------------------------------------------------------------------- 46 | ex0 :: Assertion 47 | ex0 = assertSnippet (step Nothing felixOptions) 48 | [ "import B" 49 | , "import A" 50 | ] 51 | [ "import A" 52 | , "import B" 53 | ] 54 | 55 | ex1 :: Assertion 56 | ex1 = assertSnippet (step Nothing felixOptions) 57 | [ "import B" 58 | , "import A" 59 | , "import C" 60 | , "import qualified A" 61 | , "import qualified B as X" 62 | ] 63 | [ "import A" 64 | , "import qualified A" 65 | , "import B" 66 | , "import qualified B as X" 67 | , "import C" 68 | ] 69 | 70 | ex2 :: Assertion 71 | ex2 = assertSnippet (step Nothing felixOptions) 72 | [ "import B" 73 | , "import A (X)" 74 | , "import C" 75 | , "import qualified A as Y (Y)" 76 | ] 77 | [ "import A (X)" 78 | , "import qualified A as Y (Y)" 79 | , "import B" 80 | , "import C" 81 | ] 82 | 83 | ex3 :: Assertion 84 | ex3 = assertSnippet (step Nothing felixOptions) 85 | [ "import B" 86 | , "import A (X, Z, Y)" 87 | , "import C" 88 | , "import qualified A as A0 (b, Y, a)" 89 | , "import qualified D as D0 (Y, b, a)" 90 | , "import qualified E as E0 (b, a, Y)" 91 | ] 92 | [ "import A (X, Y, Z)" 93 | , "import qualified A as A0 (Y, a, b)" 94 | , "import B" 95 | , "import C" 96 | , "import qualified D as D0 (Y, a, b)" 97 | , "import qualified E as E0 (Y, a, b)" 98 | ] 99 | 100 | ex4 :: Assertion 101 | ex4 = assertSnippet (step Nothing felixOptions) 102 | [ "import A (X, Z(..), Y)" 103 | ] 104 | [ "import A (X, Y, Z (..))" 105 | ] 106 | 107 | ex5 :: Assertion 108 | ex5 = assertSnippet (step Nothing felixOptions) 109 | [ "import A (X, Z(Z), Y)" 110 | ] 111 | [ "import A (X, Y, Z (Z))" 112 | ] 113 | 114 | ex6 :: Assertion 115 | ex6 = assertSnippet (step Nothing felixOptions) 116 | [ "import A (X, Z(X, Z, Y), Y)" 117 | ] 118 | [ "import A (X, Y, Z (X, Y, Z))" 119 | ] 120 | 121 | ex7 :: Assertion 122 | ex7 = assertSnippet (step Nothing felixOptions) 123 | [ "module Foo (tests) where" 124 | , "import B" 125 | , "import A (X, Z, Y)" 126 | , "import C" 127 | , "import qualified A as A0 (b, Y, a)" 128 | , "import qualified D as D0 (Y, b, a)" 129 | , "import qualified E as E0 (b, a, Y)" 130 | , "-- hello" 131 | , "foo :: Int" 132 | , "foo = 1" 133 | ] 134 | [ "module Foo (tests) where" 135 | , "import A (X, Y, Z)" 136 | , "import qualified A as A0 (Y, a, b)" 137 | , "import B" 138 | , "import C" 139 | , "import qualified D as D0 (Y, a, b)" 140 | , "import qualified E as E0 (Y, a, b)" 141 | , "-- hello" 142 | , "foo :: Int" 143 | , "foo = 1" 144 | ] 145 | 146 | ex8 :: Assertion 147 | ex8 = assertSnippet (step Nothing felixOptions) 148 | [ "import B" 149 | , "-- Group divisor" 150 | , "import A (X)" 151 | , "import C" 152 | , "import qualified A as Y (Y)" 153 | ] 154 | [ "import B" 155 | , "-- Group divisor" 156 | , "import A (X)" 157 | , "import qualified A as Y (Y)" 158 | , "import C" 159 | ] 160 | 161 | ex9 :: Assertion 162 | ex9 = assertSnippet (step Nothing felixOptions) 163 | [ "--------" 164 | , "import B" 165 | , "" 166 | , "-- Group divisor" 167 | , "import A (X)" 168 | , "import C" 169 | , "import qualified A as Y (Y)" 170 | ] 171 | [ "--------" 172 | , "import B" 173 | , "" 174 | , "-- Group divisor" 175 | , "import A (X)" 176 | , "import qualified A as Y (Y)" 177 | , "import C" 178 | ] 179 | 180 | ex10 :: Assertion 181 | ex10 = assertSnippet (step Nothing felixOptions) 182 | [ "import B hiding (X)" 183 | , "import A hiding (X)" 184 | ] 185 | [ "import A hiding (X)" 186 | , "import B hiding (X)" 187 | ] 188 | 189 | ex11 :: Assertion 190 | ex11 = assertSnippet (step Nothing felixOptions) 191 | [ "import Data.Aeson ((.=))" 192 | , "import A hiding (X)" 193 | ] 194 | [ "import A hiding (X)" 195 | , "import Data.Aeson ((.=))" 196 | ] 197 | 198 | ex12 :: Assertion 199 | ex12 = assertSnippet (step Nothing felixOptions) 200 | [ "import Data.Aeson ((.=))" 201 | , "import Data.Aeson ((.=))" 202 | , "import A hiding (X)" 203 | ] 204 | [ "import A hiding (X)" 205 | , "import Data.Aeson ((.=))" 206 | ] 207 | 208 | ex13 :: Assertion 209 | ex13 = assertSnippet (step (Just 10) felixOptions) 210 | [ "import Foo (A, B, C, D)" 211 | , "import A hiding (X)" 212 | ] 213 | [ "import A hiding (X)" 214 | , "import Foo (A)" 215 | , "import Foo (B)" 216 | , "import Foo (C)" 217 | , "import Foo (D)" 218 | ] 219 | 220 | ex14 :: Assertion 221 | ex14 = assertSnippet (step (Just 27) felixOptions) 222 | [ "import Foo (A, B, C, D)" 223 | , "import A hiding (X)" 224 | ] 225 | [ "import A hiding (X)" 226 | , "import Foo (A, B)" 227 | , "import Foo (C, D)" 228 | ] 229 | 230 | ex15 :: Assertion 231 | ex15 = assertSnippet (step (Just 100) felixOptions) 232 | [ "module Custom.Prelude" 233 | , " ( LazyByteString" 234 | , " , UUID" 235 | , " , decodeUtf8Lenient" 236 | , " , error" 237 | , " , headMay" 238 | , " , module X" 239 | , " , nextRandomUUID" 240 | , " , onChars" 241 | , " , proxyOf" 242 | , " , show" 243 | , " , showStr" 244 | , " , toLazyByteString" 245 | , " , toStrictByteString" 246 | , " , type (~>)" 247 | , " , uuidToText" 248 | , " ) where" 249 | , "" 250 | , "--------------------------------------------------------------------------------" 251 | , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" 252 | , "import qualified Prelude" 253 | , "" 254 | , "--------------------------------------------------------------------------------" 255 | , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans, set, to, view)" 256 | , "import Control.Lens.Extras as X (is)" 257 | , "" 258 | , "--------------------------------------------------------------------------------" 259 | , "import Control.Applicative as X ((<|>))" 260 | , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" 261 | , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" 262 | , "import Control.Monad.IO.Unlift as X" 263 | , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" 264 | , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" 265 | , "--------------------------------------------------------------------------------" 266 | ] 267 | [ "module Custom.Prelude" 268 | , " ( LazyByteString" 269 | , " , UUID" 270 | , " , decodeUtf8Lenient" 271 | , " , error" 272 | , " , headMay" 273 | , " , module X" 274 | , " , nextRandomUUID" 275 | , " , onChars" 276 | , " , proxyOf" 277 | , " , show" 278 | , " , showStr" 279 | , " , toLazyByteString" 280 | , " , toStrictByteString" 281 | , " , type (~>)" 282 | , " , uuidToText" 283 | , " ) where" 284 | , "" 285 | , "--------------------------------------------------------------------------------" 286 | , "import Prelude as X hiding (appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile, (!!))" 287 | , "import qualified Prelude" 288 | , "" 289 | , "--------------------------------------------------------------------------------" 290 | , "import Control.Lens as X (_Left, _Right, iat, over, preview, sans, set, to)" 291 | , "import Control.Lens as X (view, (%~), (&), (.~), (?~), (^.), (^?))" 292 | , "import Control.Lens.Extras as X (is)" 293 | , "" 294 | , "--------------------------------------------------------------------------------" 295 | , "import Control.Applicative as X ((<|>))" 296 | , "import Control.Monad as X (guard, unless, when, (<=<), (>=>))" 297 | , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither)" 298 | , "import Control.Monad.Except as X (runExceptT, withExceptT)" 299 | , "import Control.Monad.IO.Unlift as X" 300 | , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" 301 | , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" 302 | , "--------------------------------------------------------------------------------" 303 | ] 304 | 305 | ex16 :: Assertion 306 | ex16 = assertSnippet (step Nothing felixOptions) 307 | [ "module Foo where" 308 | , "" 309 | , "import B ()" 310 | , "import A ()" 311 | ] 312 | [ "module Foo where" 313 | , "" 314 | , "import A ()" 315 | , "import B ()" 316 | ] 317 | 318 | felixOptions :: Options 319 | felixOptions = defaultOptions 320 | { listAlign = Repeat 321 | } 322 | -------------------------------------------------------------------------------- /lib/Language/Haskell/Stylish/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE DoAndIfThenElse #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | module Language.Haskell.Stylish.Printer 9 | ( Printer(..) 10 | , PrinterConfig(..) 11 | , PrinterState(..) 12 | 13 | -- * Alias 14 | , P 15 | 16 | -- * Functions to use the printer 17 | , runPrinter 18 | , runPrinter_ 19 | 20 | -- ** Combinators 21 | , comma 22 | , dot 23 | , getCurrentLine 24 | , getCurrentLineLength 25 | , newline 26 | , parenthesize 27 | , prefix 28 | , putComment 29 | , putMaybeLineComment 30 | , putOutputable 31 | , putCond 32 | , putType 33 | , putRdrName 34 | , putText 35 | , sep 36 | , space 37 | , spaces 38 | , suffix 39 | , pad 40 | 41 | -- ** Advanced combinators 42 | , withColumns 43 | , modifyCurrentLine 44 | , wrapping 45 | ) where 46 | 47 | -------------------------------------------------------------------------------- 48 | import Prelude hiding (lines) 49 | 50 | -------------------------------------------------------------------------------- 51 | import qualified GHC.Hs as GHC 52 | import GHC.Hs.Extension (GhcPs) 53 | import GHC.Types.Name.Reader (RdrName (..)) 54 | import GHC.Types.SrcLoc (GenLocated (..)) 55 | import qualified GHC.Types.SrcLoc as GHC 56 | import GHC.TypeLits (symbolVal) 57 | import GHC.Utils.Outputable (Outputable) 58 | 59 | -------------------------------------------------------------------------------- 60 | import Control.Monad (forM_, replicateM_) 61 | import Control.Monad.Reader (MonadReader, ReaderT (..), 62 | asks, local) 63 | import Control.Monad.State (MonadState, State, get, gets, 64 | modify, put, runState) 65 | 66 | -------------------------------------------------------------------------------- 67 | import Language.Haskell.Stylish.GHC (showOutputable) 68 | import Language.Haskell.Stylish.Module (Lines) 69 | 70 | -- | Shorthand for 'Printer' monad 71 | type P = Printer 72 | 73 | -- | Printer that keeps state of file 74 | newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) 75 | deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState) 76 | 77 | -- | Configuration for printer, currently empty 78 | data PrinterConfig = PrinterConfig 79 | { columns :: !(Maybe Int) 80 | } 81 | 82 | -- | State of printer 83 | data PrinterState = PrinterState 84 | { lines :: !Lines 85 | , linePos :: !Int 86 | , currentLine :: !String 87 | } 88 | 89 | -- | Run printer to get printed lines out of module as well as return value of monad 90 | runPrinter :: PrinterConfig -> Printer a -> (a, Lines) 91 | runPrinter cfg (Printer printer) = 92 | let 93 | (a, PrinterState parsedLines _ startedLine) = runReaderT printer cfg `runState` PrinterState [] 0 "" 94 | in 95 | (a, parsedLines <> if startedLine == [] then [] else [startedLine]) 96 | 97 | -- | Run printer to get printed lines only 98 | runPrinter_ :: PrinterConfig -> Printer a -> Lines 99 | runPrinter_ cfg printer = snd (runPrinter cfg printer) 100 | 101 | -- | Print text 102 | putText :: String -> P () 103 | putText txt = do 104 | l <- gets currentLine 105 | modify \s -> s { currentLine = l <> txt } 106 | 107 | -- | Check condition post action, and use fallback if false 108 | putCond :: (PrinterState -> Bool) -> P b -> P b -> P b 109 | putCond p action fallback = do 110 | prevState <- get 111 | res <- action 112 | currState <- get 113 | if p currState then pure res 114 | else put prevState >> fallback 115 | 116 | -- | Print an 'Outputable' 117 | putOutputable :: Outputable a => a -> P () 118 | putOutputable = putText . showOutputable 119 | 120 | -- | Put all comments that has positions within 'SrcSpan' and separate by 121 | -- passed @P ()@ 122 | {- 123 | putAllSpanComments :: P () -> SrcSpan -> P () 124 | putAllSpanComments suff = \case 125 | UnhelpfulSpan _ -> pure () 126 | RealSrcSpan rspan -> do 127 | cmts <- removeComments \(L rloc _) -> 128 | srcSpanStartLine rloc >= srcSpanStartLine rspan && 129 | srcSpanEndLine rloc <= srcSpanEndLine rspan 130 | 131 | forM_ cmts (\c -> putComment c >> suff) 132 | -} 133 | 134 | -- | Print any comment 135 | putComment :: GHC.EpaComment -> P () 136 | putComment epaComment = case GHC.ac_tok epaComment of 137 | GHC.EpaDocComment hs -> putText $ show hs 138 | GHC.EpaLineComment s -> putText s 139 | GHC.EpaDocOptions s -> putText s 140 | GHC.EpaBlockComment s -> putText s 141 | 142 | putMaybeLineComment :: Maybe GHC.EpaComment -> P () 143 | putMaybeLineComment = \case 144 | Nothing -> pure () 145 | Just cmt -> space >> putComment cmt 146 | 147 | -- | Print a 'RdrName' 148 | putRdrName :: GenLocated GHC.SrcSpanAnnN RdrName -> P () 149 | putRdrName rdrName = case GHC.unLoc rdrName of 150 | Unqual name -> do 151 | let (pre, post) = nameAnnAdornment $ GHC.anns $ GHC.getLoc rdrName 152 | putText pre 153 | putText (showOutputable name) 154 | putText post 155 | Qual modulePrefix name -> 156 | putModuleName modulePrefix >> dot >> putText (showOutputable name) 157 | Orig _ name -> 158 | putText (showOutputable name) 159 | Exact name -> 160 | putText (showOutputable name) 161 | 162 | nameAnnAdornment :: GHC.NameAnn -> (String, String) 163 | nameAnnAdornment = \case 164 | GHC.NameAnn {GHC.nann_adornment = na} -> fromAdornment na 165 | GHC.NameAnnCommas {GHC.nann_adornment = na} -> fromAdornment na 166 | GHC.NameAnnBars {GHC.nann_parensh = (o, c)} -> fromAdornment (GHC.NameParensHash o c) 167 | GHC.NameAnnOnly {GHC.nann_adornment = na} -> fromAdornment na 168 | GHC.NameAnnRArrow {} -> (mempty, mempty) 169 | GHC.NameAnnQuote {} -> ("'", mempty) 170 | GHC.NameAnnTrailing {} -> (mempty, mempty) 171 | where 172 | fromAdornment (GHC.NameParens l r) = (symbolVal l, symbolVal r) 173 | fromAdornment (GHC.NameBackquotes l r) = (symbolVal l, symbolVal r) 174 | fromAdornment (GHC.NameParensHash l r) = (symbolVal l, symbolVal r) 175 | fromAdornment (GHC.NameSquare l r) = (symbolVal l, symbolVal r) 176 | fromAdornment GHC.NameNoAdornment = (mempty, mempty) 177 | 178 | -- | Print module name 179 | putModuleName :: GHC.ModuleName -> P () 180 | putModuleName = putText . GHC.moduleNameString 181 | 182 | -- | Print type 183 | putType :: GHC.LHsType GhcPs -> P () 184 | putType ltp = case GHC.unLoc ltp of 185 | GHC.HsFunTy _ arrowTp argTp funTp -> do 186 | putOutputable argTp 187 | space 188 | case arrowTp of 189 | GHC.HsUnrestrictedArrow {} -> putText "->" 190 | GHC.HsLinearArrow {} -> putText "%1 ->" 191 | GHC.HsExplicitMult {} -> putOutputable arrowTp 192 | space 193 | putType funTp 194 | GHC.HsAppTy _ t1 t2 -> 195 | putType t1 >> space >> putType t2 196 | GHC.HsExplicitListTy _ _ xs -> do 197 | putText "'[" 198 | sep 199 | (comma >> space) 200 | (fmap putType xs) 201 | putText "]" 202 | GHC.HsExplicitTupleTy _ _ xs -> do 203 | putText "'(" 204 | sep 205 | (comma >> space) 206 | (fmap putType xs) 207 | putText ")" 208 | GHC.HsOpTy _ _ lhs op rhs -> do 209 | putType lhs 210 | space 211 | putRdrName op 212 | space 213 | putType rhs 214 | GHC.HsTyVar _ flag rdrName -> do 215 | case flag of 216 | GHC.IsPromoted -> putText "'" 217 | GHC.NotPromoted -> pure () 218 | putRdrName rdrName 219 | GHC.HsTyLit _ tp -> 220 | putOutputable tp 221 | GHC.HsParTy _ tp -> do 222 | putText "(" 223 | putType tp 224 | putText ")" 225 | GHC.HsTupleTy _ _ xs -> do 226 | putText "(" 227 | sep 228 | (comma >> space) 229 | (fmap putType xs) 230 | putText ")" 231 | GHC.HsForAllTy {} -> 232 | putOutputable ltp 233 | GHC.HsQualTy {} -> 234 | putOutputable ltp 235 | GHC.HsAppKindTy _ _ _ -> 236 | putOutputable ltp 237 | GHC.HsListTy _ _ -> 238 | putOutputable ltp 239 | GHC.HsSumTy _ _ -> 240 | putOutputable ltp 241 | GHC.HsIParamTy _ _ _ -> 242 | putOutputable ltp 243 | GHC.HsKindSig _ _ _ -> 244 | putOutputable ltp 245 | GHC.HsStarTy _ _ -> 246 | putOutputable ltp 247 | GHC.HsSpliceTy _ _ -> 248 | putOutputable ltp 249 | GHC.HsDocTy _ _ _ -> 250 | putOutputable ltp 251 | GHC.HsBangTy _ _ _ -> 252 | putOutputable ltp 253 | GHC.HsRecTy _ _ -> 254 | putOutputable ltp 255 | GHC.HsWildCardTy _ -> 256 | putOutputable ltp 257 | GHC.XHsType _ -> 258 | putOutputable ltp 259 | 260 | -- | Print a newline 261 | newline :: P () 262 | newline = do 263 | l <- gets currentLine 264 | modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] } 265 | 266 | -- | Print a space 267 | space :: P () 268 | space = putText " " 269 | 270 | -- | Print a number of spaces 271 | spaces :: Int -> P () 272 | spaces i = replicateM_ i space 273 | 274 | -- | Print a dot 275 | dot :: P () 276 | dot = putText "." 277 | 278 | -- | Print a comma 279 | comma :: P () 280 | comma = putText "," 281 | 282 | -- | Add parens around a printed action 283 | parenthesize :: P a -> P a 284 | parenthesize action = putText "(" *> action <* putText ")" 285 | 286 | -- | Add separator between each element of the given printers 287 | sep :: P a -> [P a] -> P () 288 | sep _ [] = pure () 289 | sep s (first : rest) = first >> forM_ rest ((>>) s) 290 | 291 | -- | Prefix a printer with another one 292 | prefix :: P a -> P b -> P b 293 | prefix pa pb = pa >> pb 294 | 295 | -- | Suffix a printer with another one 296 | suffix :: P a -> P b -> P a 297 | suffix pa pb = pb >> pa 298 | 299 | -- | Indent to a given number of spaces. If the current line already exceeds 300 | -- that number in length, nothing happens. 301 | pad :: Int -> P () 302 | pad n = do 303 | len <- length <$> getCurrentLine 304 | spaces $ n - len 305 | 306 | -- | Get current line 307 | getCurrentLine :: P String 308 | getCurrentLine = gets currentLine 309 | 310 | -- | Get current line length 311 | getCurrentLineLength :: P Int 312 | getCurrentLineLength = fmap length getCurrentLine 313 | 314 | modifyCurrentLine :: (String -> String) -> P () 315 | modifyCurrentLine f = do 316 | s0 <- get 317 | put s0 {currentLine = f $ currentLine s0} 318 | 319 | wrapping 320 | :: P a -- ^ First printer to run 321 | -> P a -- ^ Printer to run if first printer violates max columns 322 | -> P a -- ^ Result of either the first or the second printer 323 | wrapping p1 p2 = do 324 | maxCols <- asks columns 325 | case maxCols of 326 | -- No wrapping 327 | Nothing -> p1 328 | Just c -> do 329 | s0 <- get 330 | x <- p1 331 | s1 <- get 332 | if length (currentLine s1) <= c 333 | -- No need to wrap 334 | then pure x 335 | else do 336 | put s0 337 | y <- p2 338 | s2 <- get 339 | if length (currentLine s1) == length (currentLine s2) 340 | -- Wrapping didn't help! 341 | then put s1 >> pure x 342 | -- Wrapped 343 | else pure y 344 | 345 | withColumns :: Maybe Int -> P a -> P a 346 | withColumns c = local $ \pc -> pc {columns = c} 347 | --------------------------------------------------------------------------------