From aad74d1f9d5522f2cc39aeefecef55293f148c13 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 17 Apr 2016 07:00:39 +0900 Subject: stylish-haskell (0.5.16.0-1) unstable; urgency=medium * Initial release (Closes: #821196) # imported from the archive --- .ghci | 1 + .gitignore | 20 + .travis.yml | 2 + CHANGELOG | 56 +++ LICENSE | 30 ++ README.markdown | 131 ++++++ Setup.hs | 2 + data/stylish-haskell.yaml | 154 +++++++ debian/changelog | 5 + debian/compat | 1 + debian/control | 42 ++ debian/copyright | 43 ++ debian/docs | 1 + debian/lintian-overrides | 4 + debian/manpages | 1 + debian/patches/0001-Debianize-README.patch | 34 ++ .../0002-move-CHANGELOG-entry-from-README.patch | 35 ++ debian/patches/series | 2 + debian/rules | 32 ++ debian/source/format | 1 + debian/source/lintian-overrides | 2 + debian/stylish-haskell.1.ronn | 49 +++ debian/stylish-haskell.install | 2 + debian/watch | 3 + examples/Bad.hs | 17 + lib/Language/Haskell/Stylish.hs | 92 +++++ lib/Language/Haskell/Stylish/Block.hs | 91 +++++ lib/Language/Haskell/Stylish/Config.hs | 225 +++++++++++ lib/Language/Haskell/Stylish/Editor.hs | 101 +++++ lib/Language/Haskell/Stylish/Parse.hs | 74 ++++ lib/Language/Haskell/Stylish/Step.hs | 32 ++ lib/Language/Haskell/Stylish/Step/Imports.hs | 275 +++++++++++++ .../Haskell/Stylish/Step/LanguagePragmas.hs | 168 ++++++++ lib/Language/Haskell/Stylish/Step/Records.hs | 79 ++++ lib/Language/Haskell/Stylish/Step/Tabs.hs | 21 + .../Haskell/Stylish/Step/TrailingWhitespace.hs | 22 + lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 115 ++++++ lib/Language/Haskell/Stylish/Util.hs | 128 ++++++ lib/Language/Haskell/Stylish/Verbose.hs | 20 + src/Main.hs | 90 +++++ stack.yaml | 5 + stylish-haskell.cabal | 116 ++++++ tests/Language/Haskell/Stylish/Parse/Tests.hs | 74 ++++ .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 444 +++++++++++++++++++++ .../Haskell/Stylish/Step/LanguagePragmas/Tests.hs | 169 ++++++++ .../Language/Haskell/Stylish/Step/Records/Tests.hs | 56 +++ tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs | 43 ++ .../Stylish/Step/TrailingWhitespace/Tests.hs | 39 ++ .../Haskell/Stylish/Step/UnicodeSyntax/Tests.hs | 38 ++ tests/Language/Haskell/Stylish/Tests/Util.hs | 17 + tests/TestSuite.hs | 31 ++ 51 files changed, 3235 insertions(+) create mode 100644 .ghci create mode 100644 .gitignore create mode 100644 .travis.yml create mode 100644 CHANGELOG create mode 100644 LICENSE create mode 100644 README.markdown create mode 100644 Setup.hs create mode 100644 data/stylish-haskell.yaml create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/docs create mode 100644 debian/lintian-overrides create mode 100644 debian/manpages create mode 100644 debian/patches/0001-Debianize-README.patch create mode 100644 debian/patches/0002-move-CHANGELOG-entry-from-README.patch create mode 100644 debian/patches/series create mode 100755 debian/rules create mode 100644 debian/source/format create mode 100644 debian/source/lintian-overrides create mode 100644 debian/stylish-haskell.1.ronn create mode 100644 debian/stylish-haskell.install create mode 100644 debian/watch create mode 100644 examples/Bad.hs create mode 100644 lib/Language/Haskell/Stylish.hs create mode 100644 lib/Language/Haskell/Stylish/Block.hs create mode 100644 lib/Language/Haskell/Stylish/Config.hs create mode 100644 lib/Language/Haskell/Stylish/Editor.hs create mode 100644 lib/Language/Haskell/Stylish/Parse.hs create mode 100644 lib/Language/Haskell/Stylish/Step.hs create mode 100644 lib/Language/Haskell/Stylish/Step/Imports.hs create mode 100644 lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs create mode 100644 lib/Language/Haskell/Stylish/Step/Records.hs create mode 100644 lib/Language/Haskell/Stylish/Step/Tabs.hs create mode 100644 lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs create mode 100644 lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs create mode 100644 lib/Language/Haskell/Stylish/Util.hs create mode 100644 lib/Language/Haskell/Stylish/Verbose.hs create mode 100644 src/Main.hs create mode 100644 stack.yaml create mode 100644 stylish-haskell.cabal create mode 100644 tests/Language/Haskell/Stylish/Parse/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/Imports/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/Records/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Tests/Util.hs create mode 100644 tests/TestSuite.hs diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..fd1deff --- /dev/null +++ b/.ghci @@ -0,0 +1 @@ +:set -isrc -itests -idist/build/autogen diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9072568 --- /dev/null +++ b/.gitignore @@ -0,0 +1,20 @@ +*.aux +*.chi +*.chs.h +*.dyn_hi +*.dyn_o +*.hi +*.hp +*.o +*.prof +.cabal-sandbox/ +.cabal-sandbox/ +.hpc +.hsenv +.stack-work +.stack-work/ +cabal-dev +cabal.config +cabal.sandbox.config +cabal.sandbox.config +dist diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..7d5fedb --- /dev/null +++ b/.travis.yml @@ -0,0 +1,2 @@ +language: haskell +ghc: '7.10' diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..61aa915 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,56 @@ +- 0.5.16.0 + * Fail if the default configuration file is not found. + +- 0.5.15.2 + * Bump `aeson` to 0.11 + +- 0.5.15.1 + * Fix error that caused haddock to bail on this package + +- 0.5.15.0 + * Add new options for import list alignment (by Ondřej Janošík) + +- 0.5.14.4 + * Bump `stylish-haskell` to 1.17.0 + +- 0.5.14.3 + * Bump `HUnit` to 1.13 + +- 0.5.14.2 + * Bump `aeson` to 0.10 + * Bump `syb` to 0.6 + +- 0.5.14.1 + * Bump `aeson` to 0.9 + +- 0.5.14.0 + * Bump `syb` to 0.5 + * Slight refactoring in align code + +- 0.5.13.0 + * Fix issue with shebang code + +- 0.5.12.0 + * Add support for shebang at start of file + +- 0.5.11.2 + * Bump `filepath` dependency to 1.5 + +- 0.5.11.1 + * Fix -Wall compilation with GHC 7.10 + +- 0.5.11.0 + * Bump `haskell-src-exts` dependency to 1.16 + +- 0.5.10.2 + * Bump `mtl` dependency to 2.2 + +- 0.5.10.1 + * Bump `aeson` dependency to 0.8 + +- 0.5.10.0 + * Bump `haskell-src-exts` dependency to 1.15 + * Fix test which was not run before + +- `0.5.9.0` + * Add `compact_line` setting for Language Pragma styling diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1a37f45 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Jasper Van der Jeugt + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..f6925c0 --- /dev/null +++ b/README.markdown @@ -0,0 +1,131 @@ +stylish-haskell +=============== + +Introduction +------------ + +A simple Haskell code prettifier. The goal is not to format all of the code in +a file, since I find those kind of tools often "get in the way". However, +manually cleaning up import statements etc. gets tedious very quickly. + +This tool tries to help where necessary without getting in the way. + +Features +-------- + +- Aligns and sorts `import` statements +- Groups and wraps `{-# LANGUAGE #-}` pragmas, can remove (some) redundant + pragmas +- Removes trailing whitespace +- Replaces tabs by four spaces (turned off by default) +- Replaces some ASCII sequences by their Unicode equivalents (turned off by + default) + +Feature requests are welcome! Use the [issue tracker] for that. + +[issue tracker]: https://github.com/jaspervdj/stylish-haskell/issues + +Example +------- + +Turns: + + {-# LANGUAGE ViewPatterns, TemplateHaskell #-} + {-# LANGUAGE GeneralizedNewtypeDeriving, + ViewPatterns, + ScopedTypeVariables #-} + + module Bad where + + import Control.Applicative ((<$>)) + import System.Directory (doesFileExist) + + import qualified Data.Map as M + import Data.Map ((!), keys, Map) + + data Point = Point + { pointX, pointY :: Double + , pointName :: String + } deriving (Show) + +into: + + {-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# LANGUAGE ScopedTypeVariables #-} + {-# LANGUAGE TemplateHaskell #-} + + module Bad where + + import Control.Applicative ((<$>)) + import System.Directory (doesFileExist) + + import Data.Map (Map, keys, (!)) + import qualified Data.Map as M + + data Point = Point + { pointX, pointY :: Double + , pointName :: String + } deriving (Show) + +Configuration +------------- + +The tool is customizable to some extent. It tries to find a config file in the +following order: + +1. A file passed to the tool using the `-c/--config` argument +2. `.stylish-haskell.yaml` in the current directory (useful for per-directory + settings) +3. `.stylish-haskell.yaml` in the nearest ancestor directory (useful for + per-project settings) +4. `.stylish-haskell.yaml` in your home directory (useful for user-wide + settings) +5. The default settings. + +Use `stylish-haskell --defaults > .stylish-haskell.yaml` to dump a +well-documented default configuration to a file, this way you can get started +quickly. + +VIM integration +--------------- + +Since it works as a filter it is pretty easy to integrate this with VIM. +Just call + + :%!stylish-haskell + +or add a keybinding for it. + +There is also the [vim-stylish-haskell] plugin, which runs stylish-haskell +automatically when you save a Haskell file. + +[vim-stylish-haskell]: https://github.com/nbouscal/vim-stylish-haskell + +Emacs integration +----------------- + +[haskell-mode] for Emacs supports `stylish-haskell`. For configuration, see +[Emacs/Formatting] on the HaskellWiki. + +[haskell-mode]: https://github.com/haskell/haskell-mode +[Emacs/Formatting]: http://wiki.haskell.org/Emacs/Formatting + +Atom integration +---------------- + +[ide-haskell] for Atom supports `stylish-haskell`. + +[ide-haskell]: https://atom.io/packages/ide-haskell + +Credits +------- + +Written and maintained by Jasper Van der Jeugt. + +Contributors: + +- Chris Done +- Hiromi Ishii +- Leonid Onokhov +- Michael Snoyman +- Mikhail Glushenkov diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml new file mode 100644 index 0000000..efc5695 --- /dev/null +++ b/data/stylish-haskell.yaml @@ -0,0 +1,154 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # Folowing options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after alias + list_align: after_alias + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with contructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # List padding determines indentation of import list on lines after import. + # This option affects 'list_align' and 'long_list_align'. + list_padding: 4 + + # Separate lists option affects formating of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same collumn. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Align the types in record declarations + - records: {} + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..6003858 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +stylish-haskell (0.5.16.0-1) unstable; urgency=medium + + * Initial release (Closes: #821196) + + -- Sean Whitton Sat, 16 Apr 2016 15:00:39 -0700 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..ec63514 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +9 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..e971224 --- /dev/null +++ b/debian/control @@ -0,0 +1,42 @@ +Source: stylish-haskell +Maintainer: Sean Whitton +Priority: extra +Section: haskell +Build-Depends: debhelper (>= 9), + ghc, + libghc-aeson-dev (>= 0.6), + libghc-aeson-dev (<< 0.12), + libghc-src-exts-dev (>= 1.17), + libghc-src-exts-dev (<< 1.18), + libghc-mtl-dev (>= 2.0), + libghc-mtl-dev (<< 2.3), + libghc-syb-dev (>= 0.3), + libghc-syb-dev (<< 0.7), + libghc-yaml-dev (>= 0.7), + libghc-yaml-dev (<< 0.9), + libghc-cmdargs-dev (>= 0.9), + libghc-cmdargs-dev (<< 0.11), + libghc-strict-dev (>= 0.3), + libghc-strict-dev (<< 0.4), + libghc-hunit-dev (>= 1.2), + libghc-hunit-dev (<< 1.4), + libghc-test-framework-dev (>= 0.4), + libghc-test-framework-dev (<< 0.9), + libghc-test-framework-hunit-dev (>= 0.2), + libghc-test-framework-hunit-dev (<< 0.4), + ruby-ronn, +Standards-Version: 3.9.8 +Homepage: https://github.com/jaspervdj/stylish-haskell +Vcs-Git: https://git.spwhitton.name/stylish-haskell +Vcs-Browser: https://git.spwhitton.name/?p=stylish-haskell.git;a=summary + +Package: stylish-haskell +Architecture: any +Depends: ${shlibs:Depends}, + ${misc:Depends}, +Suggests: haskell-mode +Description: Haskell code prettifier + stylish-haskell prettifies Haskell code. A design goal is not + getting in the user's way, so it restricts itself to formatting only + some parts of the Haskell code piped to it, such as import + statements. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..dd4cbf3 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,43 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: stylish-haskell +Upstream-Contact: Jasper Van der Jeugt +Source: https://github.com/jaspervdj/stylish-haskell + +Files: * +Copyright: (C) 2012-2016 Jasper Van der Jeugt +License: BSD3 + +Files: debian/* +Copyright: (C) 2016 Sean Whitton +License: BSD3 + +License: BSD3 + All rights reserved. + . + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + . + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + . + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + . + * Neither the name of Jasper Van der Jeugt nor + the names of other contributors may be used to endorse or + promote products derived from this software without specific + prior written permission. + . + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..8d526b9 --- /dev/null +++ b/debian/docs @@ -0,0 +1 @@ +README.markdown diff --git a/debian/lintian-overrides b/debian/lintian-overrides new file mode 100644 index 0000000..58bf513 --- /dev/null +++ b/debian/lintian-overrides @@ -0,0 +1,4 @@ +# standard override for Haskell binary packages +binary-or-shlib-defines-rpath +# standard override for Haskell binary packages +hardening-no-relro diff --git a/debian/manpages b/debian/manpages new file mode 100644 index 0000000..2af444d --- /dev/null +++ b/debian/manpages @@ -0,0 +1 @@ +debian/stylish-haskell.1 diff --git a/debian/patches/0001-Debianize-README.patch b/debian/patches/0001-Debianize-README.patch new file mode 100644 index 0000000..2483167 --- /dev/null +++ b/debian/patches/0001-Debianize-README.patch @@ -0,0 +1,34 @@ +From: Sean Whitton +Date: Sat, 16 Apr 2016 09:43:35 -0700 +Subject: Debianize-README +Forwarded: not-needed + +--- + README.markdown | 7 ------- + 1 file changed, 7 deletions(-) + +diff --git a/README.markdown b/README.markdown +index 857f731..201a294 100644 +--- a/README.markdown ++++ b/README.markdown +@@ -1,8 +1,6 @@ + stylish-haskell + =============== + +-[![Build Status](https://secure.travis-ci.org/jaspervdj/stylish-haskell.svg?branch=master)](http://travis-ci.org/jaspervdj/stylish-haskell) +- + Introduction + ------------ + +@@ -12,11 +10,6 @@ manually cleaning up import statements etc. gets tedious very quickly. + + This tool tries to help where necessary without getting in the way. + +-Installation +------------- +- +-You can install it using `cabal install stylish-haskell`. +- + Features + -------- + diff --git a/debian/patches/0002-move-CHANGELOG-entry-from-README.patch b/debian/patches/0002-move-CHANGELOG-entry-from-README.patch new file mode 100644 index 0000000..ca8e2ac --- /dev/null +++ b/debian/patches/0002-move-CHANGELOG-entry-from-README.patch @@ -0,0 +1,35 @@ +From: Sean Whitton +Date: Sat, 16 Apr 2016 09:44:31 -0700 +Subject: move-CHANGELOG-entry-from-README +Forwarded: https://github.com/jaspervdj/stylish-haskell/pull/101 + +--- + CHANGELOG | 3 +++ + README.markdown | 6 ------ + 2 files changed, 3 insertions(+), 6 deletions(-) + +diff --git a/CHANGELOG b/CHANGELOG +index d8f24d7..61aa915 100644 +--- a/CHANGELOG ++++ b/CHANGELOG +@@ -51,3 +51,6 @@ + - 0.5.10.0 + * Bump `haskell-src-exts` dependency to 1.15 + * Fix test which was not run before ++ ++- `0.5.9.0` ++ * Add `compact_line` setting for Language Pragma styling +diff --git a/README.markdown b/README.markdown +index 201a294..f6925c0 100644 +--- a/README.markdown ++++ b/README.markdown +@@ -129,9 +129,3 @@ Contributors: + - Leonid Onokhov + - Michael Snoyman + - Mikhail Glushenkov +- +-Changelog +---------- +- +-- `0.5.9.0` +- * Add `compact_line` setting for Language Pragma styling diff --git a/debian/patches/series b/debian/patches/series new file mode 100644 index 0000000..e5ef750 --- /dev/null +++ b/debian/patches/series @@ -0,0 +1,2 @@ +0001-Debianize-README.patch +0002-move-CHANGELOG-entry-from-README.patch diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..10e1c7d --- /dev/null +++ b/debian/rules @@ -0,0 +1,32 @@ +#!/usr/bin/make -f + +# these rules originally written by Joey Hess for hothasktags package + +%: + dh $@ + +override_dh_auto_configure: + ghc --make Setup + ./Setup configure \ + --datadir=/usr/share/stylish-haskell --datasubdir="" \ + --enable-tests + +override_dh_auto_build: + ronn debian/stylish-haskell.1 + ./Setup build + +override_dh_auto_clean: + if [ -x Setup ]; then ./Setup clean; fi + rm -f Setup Setup.o Setup.hi debian/stylish-haskell.1 + +override_dh_auto_test: + ./Setup test + +override_dh_compress: + # add file that dh_compress somehow misses + dh_compress debian/stylish-haskell/usr/share/doc/stylish-haskell/README.markdown + +override_dh_strip: + # GHC cannot produce debugging symbols so the -dbgsym package + # ends up empty, so disable generating it + dh_strip --no-automatic-dbgsym diff --git a/debian/source/format b/debian/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/debian/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/debian/source/lintian-overrides b/debian/source/lintian-overrides new file mode 100644 index 0000000..12bfc41 --- /dev/null +++ b/debian/source/lintian-overrides @@ -0,0 +1,2 @@ +# signatures not provided & watch file just for notification of existence of new versions +debian-watch-may-check-gpg-signature diff --git a/debian/stylish-haskell.1.ronn b/debian/stylish-haskell.1.ronn new file mode 100644 index 0000000..385a7d2 --- /dev/null +++ b/debian/stylish-haskell.1.ronn @@ -0,0 +1,49 @@ +stylish-haskell(1) -- simple Haskell code prettifier +==================================================== + +## SYNOPSIS + +`stylish-haskell` [<-c>|<--config=FILE>] [<-v>|<--verbose>] [<-i>|<--inplace>] []... + +`stylish-haskell` <-d>|<--defaults> + +`stylish-haskell` <-V>|<--version> + +`stylish-haskell` <-?>|<--help> + +## DESCRIPTION + +`stylish-haskell` performs automatic formatting on the Haskell code in +the files passed on the command line or piped via STDIN. It outputs +to STDOUT unless `-i` is specified. + +### Options + + * `-c`, `--config`=[]: + Override the default configuration file. + + * `-v`, `--verbose`: + Turn on verbose output. + + * `-i`, `--inplace`: + Prettify and overwrite the given files in place. + + * `-d`, `--defaults`: + Dump default config and exit. + + * `-V`, `--version`: + Output version information and exit. + + * `-?`, `--help`: + Output help text and exit. + +## FILES + + * `/usr/share/stylish-haskell/data/stylish-haskell.yaml`: + Default configuration file. + +## AUTHOR + +This manual page was originally written by Sean Whitton +<> for the Debian GNU/Linux system (but may +be used by others). diff --git a/debian/stylish-haskell.install b/debian/stylish-haskell.install new file mode 100644 index 0000000..f3756d2 --- /dev/null +++ b/debian/stylish-haskell.install @@ -0,0 +1,2 @@ +./data/stylish-haskell.yaml usr/share/stylish-haskell/data +dist/build/stylish-haskell/stylish-haskell usr/bin diff --git a/debian/watch b/debian/watch new file mode 100644 index 0000000..9e0591f --- /dev/null +++ b/debian/watch @@ -0,0 +1,3 @@ +version=3 +opts=filenamemangle=s/.+\/v?(\d\S*)\.tar\.gz/stylish-haskell-$1\.tar\.gz/ \ + https://github.com/jaspervdj/stylish-haskell/tags .*/v?(\d\S*)\.tar\.gz diff --git a/examples/Bad.hs b/examples/Bad.hs new file mode 100644 index 0000000..be9288d --- /dev/null +++ b/examples/Bad.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ViewPatterns, TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, + ViewPatterns, + ScopedTypeVariables #-} + +module Bad where + +import Control.Applicative ((<$>)) +import System.Directory (doesFileExist) + +import qualified Data.Map as M +import Data.Map ((!), keys, Map) + +data Point = Point + { pointX, pointY :: Double + , pointName :: String + } deriving (Show) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs new file mode 100644 index 0000000..103306c --- /dev/null +++ b/lib/Language/Haskell/Stylish.hs @@ -0,0 +1,92 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish + ( -- * Run + runSteps + -- * Steps + , imports + , languagePragmas + , records + , tabs + , trailingWhitespace + , unicodeSyntax + -- ** Data types + , Imports.Align (..) + , LanguagePragmas.Style (..) + -- ** Helpers + , stepName + -- * Config + , module Language.Haskell.Stylish.Config + -- * Misc + , module Language.Haskell.Stylish.Verbose + , version + , Lines + , Step + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (foldM) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config +import Language.Haskell.Stylish.Parse +import Language.Haskell.Stylish.Step +import qualified Language.Haskell.Stylish.Step.Imports as Imports +import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas +import qualified Language.Haskell.Stylish.Step.Records as Records +import qualified Language.Haskell.Stylish.Step.Tabs as Tabs +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax +import Language.Haskell.Stylish.Verbose +import Paths_stylish_haskell (version) + + +-------------------------------------------------------------------------------- +imports :: Int -- ^ columns + -> Imports.Align + -> Step +imports = Imports.step + + +-------------------------------------------------------------------------------- +languagePragmas :: Int -- ^ columns + -> LanguagePragmas.Style + -> Bool -- ^ Pad to same length in vertical mode? + -> Bool -- ^ remove redundant? + -> Step +languagePragmas = LanguagePragmas.step + + +-------------------------------------------------------------------------------- +records :: Step +records = Records.step + + +-------------------------------------------------------------------------------- +tabs :: Int -- ^ number of spaces + -> Step +tabs = Tabs.step + + +-------------------------------------------------------------------------------- +trailingWhitespace :: Step +trailingWhitespace = TrailingWhitespace.step + + +-------------------------------------------------------------------------------- +unicodeSyntax :: Bool -- ^ add language pragma? + -> Step +unicodeSyntax = UnicodeSyntax.step + + +-------------------------------------------------------------------------------- +runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines +runStep exts mfp ls step = + stepFilter step ls <$> parseModule exts mfp (unlines ls) + + +-------------------------------------------------------------------------------- +runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines + -> Either String Lines +runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs new file mode 100644 index 0000000..fd680a8 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Block + ( Block (..) + , LineBlock + , SpanBlock + , blockLength + , linesFromSrcSpan + , spanFromSrcSpan + , moveBlock + , adjacent + , merge + , overlapping + , groupAdjacent + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow (arr, (&&&), (>>>)) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +-- | Indicates a line span +data Block a = Block + { blockStart :: Int + , blockEnd :: Int + } deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +type LineBlock = Block String + + +-------------------------------------------------------------------------------- +type SpanBlock = Block Char + + +-------------------------------------------------------------------------------- +blockLength :: Block a -> Int +blockLength (Block start end) = end - start + 1 + + +-------------------------------------------------------------------------------- +linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock +linesFromSrcSpan = H.srcInfoSpan >>> + H.srcSpanStartLine &&& H.srcSpanEndLine >>> + arr (uncurry Block) + + +-------------------------------------------------------------------------------- +spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock +spanFromSrcSpan = H.srcInfoSpan >>> + H.srcSpanStartColumn &&& H.srcSpanEndColumn >>> + arr (uncurry Block) + + +-------------------------------------------------------------------------------- +moveBlock :: Int -> Block a -> Block a +moveBlock offset (Block start end) = Block (start + offset) (end + offset) + + +-------------------------------------------------------------------------------- +adjacent :: Block a -> Block a -> Bool +adjacent b1 b2 = follows b1 b2 || follows b2 b1 + where + follows (Block _ e1) (Block s2 _) = e1 + 1 == s2 + + +-------------------------------------------------------------------------------- +merge :: Block a -> Block a -> Block a +merge (Block s1 e1) (Block s2 e2) = Block (min s1 s2) (max e1 e2) + + +-------------------------------------------------------------------------------- +overlapping :: [Block a] -> Bool +overlapping blocks = + any (uncurry overlapping') $ zip blocks (drop 1 blocks) + where + overlapping' (Block _ e1) (Block s2 _) = e1 >= s2 + + +-------------------------------------------------------------------------------- +-- | Groups adjacent blocks into larger blocks +groupAdjacent :: [(Block a, b)] + -> [(Block a, [b])] +groupAdjacent = foldr go [] + where + -- This code is ugly and not optimal, and no fucks were given. + go (b1, x) gs = case break (adjacent b1 . fst) gs of + (_, []) -> (b1, [x]) : gs + (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs new file mode 100644 index 0000000..fee7594 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -0,0 +1,225 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.Stylish.Config + ( Extensions + , Config (..) + , defaultConfigFilePath + , configFilePath + , loadConfig + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM, mzero) +import Data.Aeson (FromJSON (..)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import qualified Data.ByteString as B +import Data.List (inits, + intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Yaml (decodeEither) +import System.Directory +import System.FilePath (joinPath, + splitPath, + ()) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step +import qualified Language.Haskell.Stylish.Step.Imports as Imports +import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas +import qualified Language.Haskell.Stylish.Step.Records as Records +import qualified Language.Haskell.Stylish.Step.Tabs as Tabs +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax +import Language.Haskell.Stylish.Verbose +import Paths_stylish_haskell (getDataFileName) + + +-------------------------------------------------------------------------------- +type Extensions = [String] + + +-------------------------------------------------------------------------------- +data Config = Config + { configSteps :: [Step] + , configColumns :: Int + , configLanguageExtensions :: [String] + } + + +-------------------------------------------------------------------------------- +instance FromJSON Config where + parseJSON = parseConfig + + +-------------------------------------------------------------------------------- +configFileName :: String +configFileName = ".stylish-haskell.yaml" + + +-------------------------------------------------------------------------------- +defaultConfigFilePath :: IO FilePath +defaultConfigFilePath = getDataFileName "data/stylish-haskell.yaml" + + +-------------------------------------------------------------------------------- +configFilePath :: Verbose -> Maybe FilePath -> IO FilePath +configFilePath _ (Just userSpecified) = return userSpecified +configFilePath verbose Nothing = do + current <- getCurrentDirectory + home <- getHomeDirectory + def <- defaultConfigFilePath + mbConfig <- search $ + [d configFileName | d <- ancestors current] ++ + [home configFileName, def] + + case mbConfig of + Just config -> return config + Nothing -> fail $ + "Language.Haskell.Stylish.Config.configFilePath: " ++ + "could not load default configuration at: " ++ def + where + -- All ancestors of a dir (including that dir) + ancestors :: FilePath -> [FilePath] + ancestors = init . map joinPath . reverse . inits . splitPath + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (f : fs) = do + -- TODO Maybe catch an error here, dir might be unreadable + exists <- doesFileExist f + verbose $ f ++ if exists then " exists" else " does not exist" + if exists then return (Just f) else search fs + + +-------------------------------------------------------------------------------- +loadConfig :: Verbose -> Maybe FilePath -> IO Config +loadConfig verbose mfp = do + fp <- configFilePath verbose mfp + verbose $ "Loading configuration at " ++ fp + bs <- B.readFile fp + case decodeEither bs of + Left err -> error $ + "Language.Haskell.Stylish.Config.loadConfig: " ++ err + Right config -> return config + + +-------------------------------------------------------------------------------- +parseConfig :: A.Value -> A.Parser Config +parseConfig (A.Object o) = do + -- First load the config without the actual steps + config <- Config + <$> pure [] + <*> (o A..:? "columns" A..!= 80) + <*> (o A..:? "language_extensions" A..!= []) + + -- Then fill in the steps based on the partial config we already have + stepValues <- o A..: "steps" :: A.Parser [A.Value] + steps <- mapM (parseSteps config) stepValues + return config {configSteps = concat steps} +parseConfig _ = mzero + + +-------------------------------------------------------------------------------- +catalog :: Map String (Config -> A.Object -> A.Parser Step) +catalog = M.fromList + [ ("imports", parseImports) + , ("language_pragmas", parseLanguagePragmas) + , ("records", parseRecords) + , ("tabs", parseTabs) + , ("trailing_whitespace", parseTrailingWhitespace) + , ("unicode_syntax", parseUnicodeSyntax) + ] + + +-------------------------------------------------------------------------------- +parseSteps :: Config -> A.Value -> A.Parser [Step] +parseSteps config val = do + map' <- parseJSON val :: A.Parser (Map String A.Value) + forM (M.toList map') $ \(k, v) -> case (M.lookup k catalog, v) of + (Just parser, A.Object o) -> parser config o + _ -> fail $ "Invalid declaration for " ++ k + + +-------------------------------------------------------------------------------- +-- | Utility for enum-like options +parseEnum :: [(String, a)] -> a -> Maybe String -> A.Parser a +parseEnum _ def Nothing = return def +parseEnum strs _ (Just k) = case lookup k strs of + Just v -> return v + Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++ + intercalate ", " (map fst strs) + + +-------------------------------------------------------------------------------- +parseImports :: Config -> A.Object -> A.Parser Step +parseImports config o = Imports.step + <$> pure (configColumns config) + <*> (Imports.Align + <$> (o A..:? "align" >>= parseEnum aligns Imports.Global) + <*> (o A..:? "list_align" >>= parseEnum listAligns Imports.AfterAlias) + <*> (o A..:? "long_list_align" + >>= parseEnum longListAligns Imports.Inline) + -- Note that padding has to be at least 1. Default is 4. + <*> (maybe 4 (max 1) <$> o A..:? "list_padding") + <*> o A..:? "separate_lists" A..!= True) + where + aligns = + [ ("global", Imports.Global) + , ("file", Imports.File) + , ("group", Imports.Group) + , ("none", Imports.None) + ] + + listAligns = + [ ("new_line", Imports.NewLine) + , ("with_alias", Imports.WithAlias) + , ("after_alias", Imports.AfterAlias) + ] + + longListAligns = + [ ("inline", Imports.Inline) + , ("new_line", Imports.InlineWithBreak) + , ("new_line_multiline", Imports.InlineToMultiline) + , ("multiline", Imports.Multiline) + ] + + +-------------------------------------------------------------------------------- +parseLanguagePragmas :: Config -> A.Object -> A.Parser Step +parseLanguagePragmas config o = LanguagePragmas.step + <$> pure (configColumns config) + <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) + <*> o A..:? "align" A..!= True + <*> o A..:? "remove_redundant" A..!= True + where + styles = + [ ("vertical", LanguagePragmas.Vertical) + , ("compact", LanguagePragmas.Compact) + , ("compact_line", LanguagePragmas.CompactLine) + ] + + +-------------------------------------------------------------------------------- +parseRecords :: Config -> A.Object -> A.Parser Step +parseRecords _ _ = return Records.step + + +-------------------------------------------------------------------------------- +parseTabs :: Config -> A.Object -> A.Parser Step +parseTabs _ o = Tabs.step + <$> o A..:? "spaces" A..!= 8 + + +-------------------------------------------------------------------------------- +parseTrailingWhitespace :: Config -> A.Object -> A.Parser Step +parseTrailingWhitespace _ _ = return TrailingWhitespace.step + + +-------------------------------------------------------------------------------- +parseUnicodeSyntax :: Config -> A.Object -> A.Parser Step +parseUnicodeSyntax _ o = UnicodeSyntax.step + <$> o A..:? "add_language_pragma" A..!= True diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs new file mode 100644 index 0000000..5d5a864 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -0,0 +1,101 @@ +-------------------------------------------------------------------------------- +-- | This module provides you with a line-based editor. It's main feature is +-- that you can specify multiple changes at the same time, e.g.: +-- +-- > [deleteLine 3, changeLine 4 ["Foo"]] +-- +-- when this is evaluated, we take into account that 4th line will become the +-- 3rd line before it needs changing. +module Language.Haskell.Stylish.Editor + ( Change + , applyChanges + + , change + , changeLine + , delete + , deleteLine + , insert + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block + + +-------------------------------------------------------------------------------- +-- | Changes the lines indicated by the 'Block' into the given 'Lines' +data Change a = Change + { changeBlock :: Block a + , changeLines :: ([a] -> [a]) + } + + +-------------------------------------------------------------------------------- +moveChange :: Int -> Change a -> Change a +moveChange offset (Change block ls) = Change (moveBlock offset block) ls + + +-------------------------------------------------------------------------------- +applyChanges :: [Change a] -> [a] -> [a] +applyChanges changes + | overlapping blocks = error $ + "Language.Haskell.Stylish.Editor.applyChanges: " ++ + "refusing to make overlapping changes" + | otherwise = go 1 changes + where + blocks = map changeBlock changes + + go _ [] ls = ls + go n (ch : chs) ls = + -- Divide the remaining lines into: + -- + -- > pre + -- > old (lines that are affected by the change) + -- > post + -- + -- And generate: + -- + -- > pre + -- > new + -- > (recurse) + -- + let block = changeBlock ch + (pre, ls') = splitAt (blockStart block - n) ls + (old, post) = splitAt (blockLength block) ls' + new = changeLines ch old + extraLines = length new - blockLength block + chs' = map (moveChange extraLines) chs + n' = blockStart block + blockLength block + extraLines + in pre ++ new ++ go n' chs' post + + +-------------------------------------------------------------------------------- +-- | Change a block of lines for some other lines +change :: Block a -> ([a] -> [a]) -> Change a +change = Change + + +-------------------------------------------------------------------------------- +-- | Change a single line for some other lines +changeLine :: Int -> (a -> [a]) -> Change a +changeLine start f = change (Block start start) $ \xs -> case xs of + [] -> [] + (x : _) -> f x + + +-------------------------------------------------------------------------------- +-- | Delete a block of lines +delete :: Block a -> Change a +delete block = Change block $ const [] + + +-------------------------------------------------------------------------------- +-- | Delete a single line +deleteLine :: Int -> Change a +deleteLine start = delete (Block start start) + + +-------------------------------------------------------------------------------- +-- | Insert something /before/ the given lines +insert :: Int -> [a] -> Change a +insert start = Change (Block start (start - 1)) . const diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs new file mode 100644 index 0000000..f8e24a6 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Parse + ( parseModule + ) where + + +-------------------------------------------------------------------------------- +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Language.Haskell.Exts.Annotated as H +import Data.List (isPrefixOf) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +-- | Filter out lines which use CPP macros +unCpp :: String -> String +unCpp = unlines . go False . lines + where + go _ [] = [] + go isMultiline (x : xs) = + let isCpp = isMultiline || listToMaybe x == Just '#' + nextMultiline = isCpp && not (null x) && last x == '\\' + in (if isCpp then "" else x) : go nextMultiline xs + + +-------------------------------------------------------------------------------- +-- | Remove shebang from the first line +unShebang :: String -> String +unShebang str + | "#!" `isPrefixOf` str = unlines $ ("" :) $ drop 1 $ lines str + | otherwise = str + + +-------------------------------------------------------------------------------- +-- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it +-- because haskell-src-exts can't handle it. +dropBom :: String -> String +dropBom ('\xfeff' : str) = str +dropBom str = str + + +-------------------------------------------------------------------------------- +-- | Abstraction over HSE's parsing +parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module +parseModule extraExts mfp string = do + -- Determine the extensions: those specified in the file and the extra ones + let noBom = dropBom string + extraExts' = map H.classifyExtension extraExts + (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noBom + exts = fileExts ++ extraExts' + + -- Parsing options... + fp = fromMaybe "" mfp + mode = H.defaultParseMode + { H.extensions = exts + , H.fixities = Nothing + , H.baseLanguage = case lang of + Nothing -> H.baseLanguage H.defaultParseMode + Just l -> l + } + + -- Preprocessing + processed = unShebang $ + if H.EnableExtension H.CPP `elem` exts then unCpp noBom else noBom + + case H.parseModuleWithComments mode processed of + H.ParseOk md -> return md + err -> Left $ + "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ + fp ++ ": " ++ show err diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs new file mode 100644 index 0000000..f053f8b --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -0,0 +1,32 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step + ( Lines + , Module + , Step (..) + , makeStep + ) where + + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +type Lines = [String] + + +-------------------------------------------------------------------------------- +-- | Concrete module type +type Module = (H.Module H.SrcSpanInfo, [H.Comment]) + + +-------------------------------------------------------------------------------- +data Step = Step + { stepName :: String + , stepFilter :: Lines -> Module -> Lines + } + + +-------------------------------------------------------------------------------- +makeStep :: String -> (Lines -> Module -> Lines) -> Step +makeStep = Step diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs new file mode 100644 index 0000000..82ba96f --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Imports + ( Align (..) + , ImportAlign (..) + , ListAlign (..) + , LongListAlign (..) + , step + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow ((&&&)) +import Data.Char (toLower) +import Data.List (intercalate, sortBy) +import Data.Maybe (isJust, maybeToList) +import Data.Ord (comparing) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + +-------------------------------------------------------------------------------- +data Align = Align + { importAlign :: ImportAlign + , listAlign :: ListAlign + , longListAlign :: LongListAlign + , listPadding :: Int + , separateLists :: Bool + } + deriving (Eq, Show) + +data ImportAlign + = Global + | File + | Group + | None + deriving (Eq, Show) + +data ListAlign + = NewLine + | WithAlias + | AfterAlias + deriving (Eq, Show) + +data LongListAlign + = Inline + | InlineWithBreak + | InlineToMultiline + | Multiline + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +imports :: H.Module l -> [H.ImportDecl l] +imports (H.Module _ _ _ is _) = is +imports _ = [] + + +-------------------------------------------------------------------------------- +importName :: H.ImportDecl l -> String +importName i = let (H.ModuleName _ n) = H.importModule i in n + + +-------------------------------------------------------------------------------- +longestImport :: [H.ImportDecl l] -> Int +longestImport = maximum . map (length . importName) + + +-------------------------------------------------------------------------------- +-- | Compare imports for ordering +compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering +compareImports = comparing (map toLower . importName &&& H.importQualified) + + +-------------------------------------------------------------------------------- +-- | The implementation is a bit hacky to get proper sorting for input specs: +-- constructors first, followed by functions, and then operators. +compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering +compareImportSpecs = comparing key + where + key :: H.ImportSpec l -> (Int, Bool, String) + key (H.IVar _ x) = (1, isOperator x, nameToString x) + key (H.IAbs _ _ x) = (0, False, nameToString x) + key (H.IThingAll _ x) = (0, False, nameToString x) + key (H.IThingWith _ x _) = (0, False, nameToString x) + + +-------------------------------------------------------------------------------- +-- | Sort the input spec list inside an 'H.ImportDecl' +sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l +sortImportSpecs imp = imp {H.importSpecs = sort' <$> H.importSpecs imp} + where + sort' (H.ImportSpecList l h specs) = H.ImportSpecList l h $ + sortBy compareImportSpecs specs + + +-------------------------------------------------------------------------------- +-- | Order of imports in sublist is: +-- Constructors, accessors/methods, operators. +compareImportSubSpecs :: H.CName l -> H.CName l -> Ordering +compareImportSubSpecs = comparing key + where + key :: H.CName l -> (Int, Bool, String) + key (H.ConName _ x) = (0, False, nameToString x) + key (H.VarName _ x) = (1, isOperator x, nameToString x) + + +-------------------------------------------------------------------------------- +-- | By default, haskell-src-exts pretty-prints +-- +-- > import Foo (Bar(..)) +-- +-- but we want +-- +-- > import Foo (Bar (..)) +-- +-- instead. +prettyImportSpec :: (Ord l) => Bool -> H.ImportSpec l -> String +prettyImportSpec separate = prettyImportSpec' + where + prettyImportSpec' (H.IThingAll _ n) = H.prettyPrint n ++ sep "(..)" + prettyImportSpec' (H.IThingWith _ n cns) = H.prettyPrint n + ++ sep "(" + ++ intercalate ", " + (map H.prettyPrint $ sortBy compareImportSubSpecs cns) + ++ ")" + prettyImportSpec' x = H.prettyPrint x + + sep = if separate then (' ' :) else id + + +-------------------------------------------------------------------------------- +prettyImport :: (Ord l, Show l) => + Int -> Align -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] +prettyImport columns Align{..} padQualified padName longest imp = + case longListAlign of + Inline -> inlineWrap + InlineWithBreak -> longListWrapper inlineWrap inlineWithBreakWrap + InlineToMultiline -> longListWrapper inlineWrap inlineToMultilineWrap + Multiline -> longListWrapper inlineWrap multilineWrap + where + longListWrapper shortWrap longWrap + | listAlign == NewLine + || length shortWrap > 1 + || length (head shortWrap) > columns + = longWrap + | otherwise = shortWrap + + inlineWrap = inlineWrapper + $ mapSpecs + $ withInit (++ ",") + . withHead ("(" ++) + . withLast (++ ")") + + inlineWrapper = case listAlign of + NewLine -> (paddedNoSpecBase :) . wrapRest columns listPadding + WithAlias -> wrap columns paddedBase (inlineBaseLength + 1) + -- Add 1 extra space to ensure same padding as in original code. + AfterAlias -> withTail (' ' :) + . wrap columns paddedBase (afterAliasBaseLength + 1) + + inlineWithBreakWrap = paddedNoSpecBase : wrapRest columns listPadding + ( mapSpecs + $ withInit (++ ",") + . withHead ("(" ++) + . withLast (++ ")")) + + inlineToMultilineWrap + | length inlineWithBreakWrap > 2 + || any ((> columns) . length) (tail inlineWithBreakWrap) + = multilineWrap + | otherwise = inlineWithBreakWrap + + -- 'wrapRest 0' ensures that every item of spec list is on new line. + multilineWrap = paddedNoSpecBase : wrapRest 0 listPadding + ( mapSpecs + ( withHead ("( " ++) + . withTail (", " ++)) + ++ [")"]) + + paddedBase = base $ padImport $ importName imp + + paddedNoSpecBase = base $ padImportNoSpec $ importName imp + + padImport = if hasExtras && padName + then padRight longest + else id + + padImportNoSpec = if (isJust (H.importAs imp) || hasHiding) && padName + then padRight longest + else id + + base' baseName importAs hasHiding' = unwords $ concat $ filter (not . null) + [ ["import"] + , qualified + , show <$> maybeToList (H.importPkg imp) + , [baseName] + , importAs + , hasHiding' + ] + + base baseName = base' baseName + ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] + ["hiding" | hasHiding] + + inlineBaseLength = length $ base' (padImport $ importName imp) [] [] + + afterAliasBaseLength = length $ base' (padImport $ importName imp) + ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] [] + + (hasHiding, importSpecs) = case H.importSpecs imp of + Just (H.ImportSpecList _ h l) -> (h, Just l) + _ -> (False, Nothing) + + hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) + + qualified + | H.importQualified imp = ["qualified"] + | padQualified = [" "] + | otherwise = [] + + mapSpecs f = case importSpecs of + Nothing -> [] -- Import everything + Just [] -> ["()"] -- Instance only imports + Just is -> f $ map (prettyImportSpec separateLists) is + + +-------------------------------------------------------------------------------- +prettyImportGroup :: Int -> Align -> Bool -> Int + -> [H.ImportDecl LineBlock] + -> Lines +prettyImportGroup columns align fileAlign longest imps = + concatMap (prettyImport columns align padQual padName longest') $ + sortBy compareImports imps + where + align' = importAlign align + + longest' = case align' of + Group -> longestImport imps + _ -> longest + + padName = align' /= None + + padQual = case align' of + Global -> True + File -> fileAlign + Group -> any H.importQualified imps + None -> False + + +-------------------------------------------------------------------------------- +step :: Int -> Align -> Step +step columns = makeStep "Imports" . step' columns + + +-------------------------------------------------------------------------------- +step' :: Int -> Align -> Lines -> Module -> Lines +step' columns align ls (module', _) = applyChanges + [ change block $ const $ + prettyImportGroup columns align fileAlign longest importGroup + | (block, importGroup) <- groups + ] + ls + where + imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' + longest = longestImport imps + groups = groupAdjacent [(H.ann i, i) | i <- imps] + + fileAlign = case importAlign align of + File -> any H.importQualified imps + _ -> False diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs new file mode 100644 index 0000000..0239736 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -0,0 +1,168 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.LanguagePragmas + ( Style (..) + , step + + -- * Utilities + , addLanguagePragma + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Set as S +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +data Style + = Vertical + | Compact + | CompactLine + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +pragmas :: H.Module l -> [(l, [String])] +pragmas (H.Module _ _ ps _ _) = + [(l, map nameToString names) | H.LanguagePragma l names <- ps] +pragmas _ = [] + + +-------------------------------------------------------------------------------- +-- | The start of the first block +firstLocation :: [(Block a, [String])] -> Int +firstLocation = minimum . map (blockStart . fst) + + +-------------------------------------------------------------------------------- +verticalPragmas :: Int -> Bool -> [String] -> Lines +verticalPragmas longest align pragmas' = + [ "{-# LANGUAGE " ++ pad pragma ++ " #-}" + | pragma <- pragmas' + ] + where + pad + | align = padRight longest + | otherwise = id + + +-------------------------------------------------------------------------------- +compactPragmas :: Int -> [String] -> Lines +compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $ + map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] + + +-------------------------------------------------------------------------------- +compactLinePragmas :: Int -> Bool -> [String] -> Lines +compactLinePragmas _ _ [] = [] +compactLinePragmas columns align pragmas' = map (wrapLanguage . pad) prags + where + wrapLanguage ps = "{-# LANGUAGE" ++ ps ++ " #-}" + + maxWidth = columns - 16 + + longest = maximum $ map length prags + + pad + | align = padRight longest + | otherwise = id + + prags = map truncateComma $ wrap maxWidth "" 1 $ + map (++ ",") (init pragmas') ++ [last pragmas'] + + +-------------------------------------------------------------------------------- +truncateComma :: String -> String +truncateComma "" = "" +truncateComma xs + | last xs == ',' = init xs + | otherwise = xs + + +-------------------------------------------------------------------------------- +prettyPragmas :: Int -> Int -> Bool -> Style -> [String] -> Lines +prettyPragmas _ longest align Vertical = verticalPragmas longest align +prettyPragmas cols _ _ Compact = compactPragmas cols +prettyPragmas cols _ align CompactLine = compactLinePragmas cols align + + +-------------------------------------------------------------------------------- +-- | Filter redundant (and duplicate) pragmas out of the groups. As a side +-- effect, we also sort the pragmas in their group... +filterRedundant :: (String -> Bool) + -> [(l, [String])] + -> [(l, [String])] +filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) + where + filterRedundant' (l, xs) (known, zs) + | S.null xs' = (known', zs) + | otherwise = (known', (l, S.toAscList xs') : zs) + where + fxs = filter (not . isRedundant') xs + xs' = S.fromList fxs `S.difference` known + known' = xs' `S.union` known + +-------------------------------------------------------------------------------- +step :: Int -> Style -> Bool -> Bool -> Step +step = (((makeStep "LanguagePragmas" .) .) .) . step' + + +-------------------------------------------------------------------------------- +step' :: Int -> Style -> Bool -> Bool -> Lines -> Module -> Lines +step' columns style align removeRedundant ls (module', _) + | null pragmas' = ls + | otherwise = applyChanges changes ls + where + isRedundant' + | removeRedundant = isRedundant module' + | otherwise = const False + + pragmas' = pragmas $ fmap linesFromSrcSpan module' + longest = maximum $ map length $ snd =<< pragmas' + groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] + changes = + [ change b (const $ prettyPragmas columns longest align style pg) + | (b, pg) <- filterRedundant isRedundant' groups + ] + + +-------------------------------------------------------------------------------- +-- | Add a LANGUAGE pragma to a module if it is not present already. +addLanguagePragma :: String -> H.Module H.SrcSpanInfo -> [Change String] +addLanguagePragma prag modu + | prag `elem` present = [] + | otherwise = [insert line ["{-# LANGUAGE " ++ prag ++ " #-}"]] + where + pragmas' = pragmas (fmap linesFromSrcSpan modu) + present = concatMap snd pragmas' + line = if null pragmas' then 1 else firstLocation pragmas' + + +-------------------------------------------------------------------------------- +-- | Check if a language pragma is redundant. We can't do this for all pragmas, +-- but we do a best effort. +isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool +isRedundant m "ViewPatterns" = isRedundantViewPatterns m +isRedundant m "BangPatterns" = isRedundantBangPatterns m +isRedundant _ _ = False + + +-------------------------------------------------------------------------------- +-- | Check if the ViewPatterns language pragma is redundant. +isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool +isRedundantViewPatterns m = null + [() | H.PViewPat _ _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] + + +-------------------------------------------------------------------------------- +-- | Check if the BangPatterns language pragma is redundant. +isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool +isRedundantBangPatterns m = null + [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] diff --git a/lib/Language/Haskell/Stylish/Step/Records.hs b/lib/Language/Haskell/Stylish/Step/Records.hs new file mode 100644 index 0000000..c8f6d19 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Records.hs @@ -0,0 +1,79 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Records + ( step + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) +import Data.List (nub) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +records :: H.Module l -> [[Alignable l]] +records modu = + [ map fieldDeclToAlignable fields + | H.Module _ _ _ _ decls <- [modu] + , H.DataDecl _ _ _ _ cons _ <- decls + , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons + ] + + +-------------------------------------------------------------------------------- +data Alignable a = Alignable + { aContainer :: !a + , aLeft :: !a + , aRight :: !a + } deriving (Show) + + +-------------------------------------------------------------------------------- +fieldDeclToAlignable :: H.FieldDecl a -> Alignable a +fieldDeclToAlignable (H.FieldDecl ann names ty) = Alignable + { aContainer = ann + , aLeft = H.ann (last names) + , aRight = H.ann ty + } + + +-------------------------------------------------------------------------------- +-- | Align the type of a field +align :: [Alignable H.SrcSpan] -> [Change String] +align alignment = map align' alignment + where + longest = maximum $ map (H.srcSpanEndColumn . aLeft) alignment + + align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str -> + let column = H.srcSpanEndColumn $ aLeft a + (pre, post) = splitAt column str + in [padRight longest (trimRight pre) ++ trimLeft post] + + trimLeft = dropWhile isSpace + trimRight = reverse . trimLeft . reverse + + +-------------------------------------------------------------------------------- +-- | Checks that all no field of the record appears on more than one line, +-- amonst other things +fixable :: [Alignable H.SrcSpan] -> Bool +fixable [] = False +fixable fields = all singleLine containers && nonOverlapping containers + where + containers = map aContainer fields + singleLine s = H.srcSpanStartLine s == H.srcSpanEndLine s + nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss) + + +-------------------------------------------------------------------------------- +step :: Step +step = makeStep "Records" $ \ls (module', _) -> + let module'' = fmap H.srcInfoSpan module' + fixableRecords = filter fixable $ records module'' + in applyChanges (fixableRecords >>= align) ls diff --git a/lib/Language/Haskell/Stylish/Step/Tabs.hs b/lib/Language/Haskell/Stylish/Step/Tabs.hs new file mode 100644 index 0000000..0694cd9 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Tabs.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Tabs + ( step + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +removeTabs :: Int -> String -> String +removeTabs spaces = concatMap removeTabs' + where + removeTabs' '\t' = replicate spaces ' ' + removeTabs' x = [x] + + +-------------------------------------------------------------------------------- +step :: Int -> Step +step spaces = makeStep "Tabs" $ \ls _ -> map (removeTabs spaces) ls diff --git a/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs b/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs new file mode 100644 index 0000000..dbc594c --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs @@ -0,0 +1,22 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.TrailingWhitespace + ( step + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +dropTrailingWhitespace :: String -> String +dropTrailingWhitespace = reverse . dropWhile isSpace . reverse + + +-------------------------------------------------------------------------------- +step :: Step +step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs new file mode 100644 index 0000000..1e00275 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -0,0 +1,115 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.UnicodeSyntax + ( step + ) where + + +-------------------------------------------------------------------------------- +import Data.List (isPrefixOf, sort) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (maybeToList) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +unicodeReplacements :: Map String String +unicodeReplacements = M.fromList + [ ("::", "∷") + , ("=>", "⇒") + , ("->", "→") + ] + + +-------------------------------------------------------------------------------- +replaceAll :: [(Int, [(Int, String)])] -> [Change String] +replaceAll = map changeLine' + where + changeLine' (r, ns) = changeLine r $ \str -> return $ + flip applyChanges str + [ change (Block c ec) (const repl) + | (c, needle) <- sort ns + , let ec = c + length needle - 1 + , repl <- maybeToList $ M.lookup needle unicodeReplacements + ] + + +-------------------------------------------------------------------------------- +groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] +groupPerLine = M.toList . M.fromListWith (++) . + map (\((r, c), x) -> (r, [(c, x)])) + + +-------------------------------------------------------------------------------- +typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeSigs module' ls = + [ (pos, "::") + | H.TypeSig loc _ _ <- everything module' :: [H.Decl H.SrcSpanInfo] + , (start, end) <- infoPoints loc + , pos <- maybeToList $ between start end "::" ls + ] + + +-------------------------------------------------------------------------------- +contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +contexts module' ls = + [ (pos, "=>") + | context <- everything module' :: [H.Context H.SrcSpanInfo] + , (start, end) <- infoPoints $ H.ann context + , pos <- maybeToList $ between start end "=>" ls + ] + + +-------------------------------------------------------------------------------- +typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeFuns module' ls = + [ (pos, "->") + | H.TyFun _ t1 t2 <- everything module' + , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1 + , let end = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2 + , pos <- maybeToList $ between start end "->" ls + ] + + +-------------------------------------------------------------------------------- +-- | Search for a needle in a haystack of lines. Only part the inside (startRow, +-- startCol), (endRow, endCol) is searched. The return value is the position of +-- the needle. +between :: (Int, Int) -> (Int, Int) -> String -> Lines -> Maybe (Int, Int) +between (startRow, startCol) (endRow, endCol) needle = + search (startRow, startCol) . + withLast (take endCol) . + withHead (drop $ startCol - 1) . + take (endRow - startRow + 1) . + drop (startRow - 1) + where + search _ [] = Nothing + search (r, _) ([] : xs) = search (r + 1, 1) xs + search (r, c) (x : xs) + | needle `isPrefixOf` x = Just (r, c) + | otherwise = search (r, c + 1) (tail x : xs) + + +-------------------------------------------------------------------------------- +step :: Bool -> Step +step = makeStep "UnicodeSyntax" . step' + + +-------------------------------------------------------------------------------- +step' :: Bool -> Lines -> Module -> Lines +step' alp ls (module', _) = applyChanges changes ls + where + changes = (if alp then addLanguagePragma "UnicodeSyntax" module' else []) ++ + replaceAll perLine + perLine = sort $ groupPerLine $ + typeSigs module' ls ++ + contexts module' ls ++ + typeFuns module' ls diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs new file mode 100644 index 0000000..ed5de91 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -0,0 +1,128 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Util + ( nameToString + , isOperator + , indent + , padRight + , everything + , infoPoints + , wrap + , wrapRest + + , withHead + , withInit + , withTail + , withLast + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow ((&&&), (>>>)) +import Data.Char (isAlpha) +import Data.Data (Data) +import qualified Data.Generics as G +import Data.Maybe (fromMaybe, listToMaybe, maybeToList) +import Data.Typeable (cast) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +nameToString :: H.Name l -> String +nameToString (H.Ident _ str) = str +nameToString (H.Symbol _ str) = str + + +-------------------------------------------------------------------------------- +isOperator :: H.Name l -> Bool +isOperator = fromMaybe False + . (fmap (not . isAlpha) . listToMaybe) + . nameToString + +-------------------------------------------------------------------------------- +indent :: Int -> String -> String +indent len = (indentPrefix len ++) + + +-------------------------------------------------------------------------------- +indentPrefix :: Int -> String +indentPrefix = (`replicate` ' ') + + +-------------------------------------------------------------------------------- +padRight :: Int -> String -> String +padRight len str = str ++ replicate (len - length str) ' ' + + +-------------------------------------------------------------------------------- +everything :: (Data a, Data b) => a -> [b] +everything = G.everything (++) (maybeToList . cast) + + +-------------------------------------------------------------------------------- +infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] +infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd) + + +-------------------------------------------------------------------------------- +wrap :: Int -- ^ Maximum line width + -> String -- ^ Leading string + -> Int -- ^ Indentation + -> [String] -- ^ Strings to add/wrap + -> Lines -- ^ Resulting lines +wrap maxWidth leading ind = wrap' leading + where + wrap' ss [] = [ss] + wrap' ss (str:strs) + | overflows ss str = + ss : wrapRest maxWidth ind (str:strs) + | otherwise = wrap' (ss ++ " " ++ str) strs + + overflows ss str = length ss > maxWidth || + ((length ss + length str) >= maxWidth && ind + length str <= maxWidth) + + +-------------------------------------------------------------------------------- +wrapRest :: Int + -> Int + -> [String] + -> Lines +wrapRest maxWidth ind = reverse . wrapRest' [] "" + where + wrapRest' ls ss [] + | null ss = ls + | otherwise = ss:ls + wrapRest' ls ss (str:strs) + | null ss = wrapRest' ls (indent ind str) strs + | overflows ss str = wrapRest' (ss:ls) "" (str:strs) + | otherwise = wrapRest' ls (ss ++ " " ++ str) strs + + overflows ss str = (length ss + length str + 1) >= maxWidth + + +-------------------------------------------------------------------------------- +withHead :: (a -> a) -> [a] -> [a] +withHead _ [] = [] +withHead f (x : xs) = f x : xs + + +-------------------------------------------------------------------------------- +withLast :: (a -> a) -> [a] -> [a] +withLast _ [] = [] +withLast f [x] = [f x] +withLast f (x : xs) = x : withLast f xs + + +-------------------------------------------------------------------------------- +withInit :: (a -> a) -> [a] -> [a] +withInit _ [] = [] +withInit _ [x] = [x] +withInit f (x : xs) = f x : withInit f xs + +-------------------------------------------------------------------------------- +withTail :: (a -> a) -> [a] -> [a] +withTail _ [] = [] +withTail f (x : xs) = x : map f xs diff --git a/lib/Language/Haskell/Stylish/Verbose.hs b/lib/Language/Haskell/Stylish/Verbose.hs new file mode 100644 index 0000000..5519e43 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Verbose.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Verbose + ( Verbose + , makeVerbose + ) where + + +-------------------------------------------------------------------------------- +import System.IO (hPutStrLn, stderr) + + +-------------------------------------------------------------------------------- +type Verbose = String -> IO () + + +-------------------------------------------------------------------------------- +makeVerbose :: Bool -> Verbose +makeVerbose verbose + | verbose = hPutStrLn stderr + | otherwise = const $ return () diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..203ab52 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,90 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} +module Main + ( main + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM_) +import Data.List (intercalate) +import Data.Version (Version(..)) +import System.Console.CmdArgs +import System.IO (hPutStrLn, stderr, withFile, hSetEncoding, IOMode(ReadMode), utf8) +import System.IO.Strict (hGetContents) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish + + +-------------------------------------------------------------------------------- +data StylishArgs = StylishArgs + { config :: Maybe FilePath + , verbose :: Bool + , defaults :: Bool + , inPlace :: Bool + , files :: [FilePath] + } deriving (Data, Show, Typeable) + + +-------------------------------------------------------------------------------- +stylishArgs :: StylishArgs +stylishArgs = StylishArgs + { config = Nothing &= typFile &= help "Configuration file" + , verbose = False &= help "Run in verbose mode" + , defaults = False &= help "Dump default config and exit" + , inPlace = False &= help "Overwrite the given files in place" + , files = [] &= typFile &= args + } &= summary ("stylish-haskell-" ++ versionString version) + where + versionString = intercalate "." . map show . versionBranch + + +-------------------------------------------------------------------------------- +main :: IO () +main = cmdArgs stylishArgs >>= stylishHaskell + + +-------------------------------------------------------------------------------- +stylishHaskell :: StylishArgs -> IO () +stylishHaskell sa + | defaults sa = do + fileName <- defaultConfigFilePath + verbose' $ "Dumping config from " ++ fileName + readUTF8File fileName >>= putStr + | otherwise = do + conf <- loadConfig verbose' (config sa) + let steps = configSteps conf + forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" + verbose' $ "Extra language extensions: " ++ + show (configLanguageExtensions conf) + mapM_ (file sa conf) files' + where + verbose' = makeVerbose (verbose sa) + files' = if null (files sa) then [Nothing] else map Just (files sa) + + +-------------------------------------------------------------------------------- +-- | Processes a single file, or stdin if no filepath is given +file :: StylishArgs -> Config -> Maybe FilePath -> IO () +file sa conf mfp = do + contents <- maybe getContents readUTF8File mfp + let result = runSteps (configLanguageExtensions conf) + mfp (configSteps conf) $ lines contents + case result of + Left err -> hPutStrLn stderr err >> write contents contents + Right ok -> write contents $ unlines ok + where + write old new = case mfp of + Nothing -> putStr new + Just _ | not (inPlace sa) -> putStr new + Just path | length new /= 0 && old /= new -> writeFile path new + _ -> return () + +readUTF8File :: FilePath -> IO String +readUTF8File fp = + withFile fp ReadMode $ \h -> do + hSetEncoding h utf8 + content <- hGetContents h + return content diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..f8a01a5 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-5.0 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal new file mode 100644 index 0000000..b2273f7 --- /dev/null +++ b/stylish-haskell.cabal @@ -0,0 +1,116 @@ +Name: stylish-haskell +Version: 0.5.16.0 +Synopsis: Haskell code prettifier +Homepage: https://github.com/jaspervdj/stylish-haskell +License: BSD3 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Copyright: 2012 Jasper Van der Jeugt +Category: Language +Build-type: Simple +Cabal-version: >= 1.8 + +Description: + A Haskell code prettifier. For more information, see: + + . + + + +Data-files: + data/stylish-haskell.yaml + +Extra-source-files: + CHANGELOG + +Library + Exposed-modules: Language.Haskell.Stylish + Hs-source-dirs: lib + Ghc-options: -Wall + + Other-modules: + Language.Haskell.Stylish.Block + Language.Haskell.Stylish.Config + Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Parse + Language.Haskell.Stylish.Step + Language.Haskell.Stylish.Step.Imports + Language.Haskell.Stylish.Step.LanguagePragmas + Language.Haskell.Stylish.Step.Records + Language.Haskell.Stylish.Step.Tabs + Language.Haskell.Stylish.Step.TrailingWhitespace + Language.Haskell.Stylish.Step.UnicodeSyntax + Language.Haskell.Stylish.Util + Language.Haskell.Stylish.Verbose + Paths_stylish_haskell + + Build-depends: + aeson >= 0.6 && < 0.12, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.5, + haskell-src-exts >= 1.17 && < 1.18, + mtl >= 2.0 && < 2.3, + syb >= 0.3 && < 0.7, + yaml >= 0.7 && < 0.9 + +Executable stylish-haskell + Ghc-options: -Wall + Hs-source-dirs: src + Main-is: Main.hs + + Build-depends: + stylish-haskell, + strict >= 0.3 && < 0.4, + cmdargs >= 0.9 && < 0.11, + -- Copied from regular dependencies... + aeson >= 0.6 && < 0.12, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.5, + haskell-src-exts >= 1.17 && < 1.18, + mtl >= 2.0 && < 2.3, + syb >= 0.3 && < 0.7, + yaml >= 0.7 && < 0.9 + +Test-suite stylish-haskell-tests + Ghc-options: -Wall + Hs-source-dirs: tests lib + Main-is: TestSuite.hs + Type: exitcode-stdio-1.0 + + Other-modules: + Language.Haskell.Stylish.Parse.Tests + Language.Haskell.Stylish.Step.Imports.Tests + Language.Haskell.Stylish.Step.LanguagePragmas.Tests + Language.Haskell.Stylish.Step.Records.Tests + Language.Haskell.Stylish.Step.Tabs.Tests + Language.Haskell.Stylish.Step.TrailingWhitespace.Tests + Language.Haskell.Stylish.Step.UnicodeSyntax.Tests + Language.Haskell.Stylish.Tests.Util + + Build-depends: + HUnit >= 1.2 && < 1.4, + test-framework >= 0.4 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, + -- Copied from regular dependencies... + aeson >= 0.6 && < 0.12, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + cmdargs >= 0.9 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.5, + haskell-src-exts >= 1.17 && < 1.18, + mtl >= 2.0 && < 2.3, + syb >= 0.3 && < 0.7, + yaml >= 0.7 && < 0.9 + +Source-repository head + Type: git + Location: https://github.com/jaspervdj/stylish-haskell diff --git a/tests/Language/Haskell/Stylish/Parse/Tests.hs b/tests/Language/Haskell/Stylish/Parse/Tests.hs new file mode 100644 index 0000000..d5f3c1d --- /dev/null +++ b/tests/Language/Haskell/Stylish/Parse/Tests.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Parse.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Parse + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Parse" + [ testCase "UTF-8 Byte Order Mark" testBom + , testCase "Extra extensions" testExtraExtensions + , testCase "Multiline CPP" testMultilineCpp + , testCase "Haskell2010 extension" testHaskell2010 + , testCase "Shebang" testShebang + ] + + +-------------------------------------------------------------------------------- +testBom :: Assertion +testBom = assert $ isRight $ parseModule [] Nothing input + where + input = unlines + [ '\xfeff' : "foo :: Int" + , "foo = 3" + ] + + +-------------------------------------------------------------------------------- +testExtraExtensions :: Assertion +testExtraExtensions = assert $ isRight $ + parseModule ["TemplateHaskell"] Nothing "$(foo)" + + +-------------------------------------------------------------------------------- +testMultilineCpp :: Assertion +testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines + [ "{-# LANGUAGE CPP #-}" + , "#define foo bar \\" + , " qux" + ] + + +-------------------------------------------------------------------------------- +testHaskell2010 :: Assertion +testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines + [ "{-# LANGUAGE Haskell2010 #-}" + , "module X where" + , "foo x | Just y <- x = y" + ] + + +-------------------------------------------------------------------------------- +testShebang :: Assertion +testShebang = assert $ isRight $ parseModule [] Nothing $ unlines + [ "#!runhaskell" + , "module Main where" + , "main = return ()" + ] + + +-------------------------------------------------------------------------------- +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs new file mode 100644 index 0000000..4ed0bd6 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -0,0 +1,444 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Imports.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Imports +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +defaultAlign :: Align +defaultAlign = Align Global AfterAlias Inline 4 True + + +-------------------------------------------------------------------------------- +fromImportAlign :: ImportAlign -> Align +fromImportAlign align = defaultAlign { importAlign = align } + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 + , testCase "case 04" case04 + , testCase "case 05" case05 + , testCase "case 06" case06 + , testCase "case 07" case07 + , testCase "case 08" case08 + , testCase "case 09" case09 + , testCase "case 10" case10 + , testCase "case 11" case11 + , testCase "case 12" case12 + , testCase "case 13" case13 + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 + , testCase "case 18" case18 + ] + + +-------------------------------------------------------------------------------- +input :: String +input = unlines + [ "module Herp where" + , "" + , "import qualified Data.Map as M" + , "import Control.Monad" + , "import Only.Instances()" + , "import Data.Map (lookup, (!), insert, Map)" + , "import Data.List as List (concat, foldl, foldr, head, init, last,\ + \ length, map, null, reverse, tail, (++))" + , "" + , "import Herp.Derp.Internals hiding (foo)" + , "import Foo (Bar (..))" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 80 $ fromImportAlign Global) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse," + , " tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step 80 $ fromImportAlign Group) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last," + , " length, map, null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = expected @=? testStep (step 80 $ fromImportAlign None) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map," + , " null, reverse, tail, (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case04 :: Assertion +case04 = expected @=? testStep (step 80 $ fromImportAlign Global) input' + where + input' = + "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ + "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" + + expected = unlines + [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," + , " object, parseEither, typeMismatch, (.!=)," + , " (.:), (.:?), (.=))" + ] + + +-------------------------------------------------------------------------------- +case05 :: Assertion +case05 = input' @=? testStep (step 80 $ fromImportAlign Group) input' + where + input' = "import Distribution.PackageDescription.Configuration " ++ + "(finalizePackageDescription)\n" + + +-------------------------------------------------------------------------------- +case06 :: Assertion +case06 = input' @=? testStep (step 80 $ fromImportAlign File) input' + where + input' = unlines + [ "import Bar.Qux" + , "import Foo.Bar" + ] + + +-------------------------------------------------------------------------------- +case07 :: Assertion +case07 = expected @=? testStep (step 80 $ fromImportAlign File) input' + where + input' = unlines + [ "import Bar.Qux" + , "" + , "import qualified Foo.Bar" + ] + + expected = unlines + [ "import Bar.Qux" + , "" + , "import qualified Foo.Bar" + ] + + +-------------------------------------------------------------------------------- +case08 :: Assertion +case08 = expected + @=? testStep (step 80 $ Align Global WithAlias Inline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case09 :: Assertion +case09 = expected + @=? testStep (step 80 $ Align Global WithAlias Multiline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case10 :: Assertion +case10 = expected + @=? testStep (step 40 $ Align Group WithAlias Multiline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map" + , " ( Map" + , " , insert" + , " , lookup" + , " , (!)" + , " )" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case11 :: Assertion +case11 = expected + @=? testStep (step 80 $ Align Group NewLine Inline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map" + , " (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances" + , " ()" + , "" + , "import Foo" + , " (Bar (..))" + , "import Herp.Derp.Internals hiding" + , " (foo)" + + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case12 :: Assertion +case12 = expected + @=? testStep (step 80 $ Align Group NewLine Inline 2 True) input' + where + input' = unlines + [ "import Data.List (map)" + ] + + expected = unlines + [ "import Data.List" + , " (map)" + ] + + +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = expected + @=? testStep (step 80 $ Align None WithAlias InlineWithBreak 4 True) input' + where + input' = unlines + [ "import qualified Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail, (++))" + ] + + expected = unlines + [ "import qualified Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + ] + + +-------------------------------------------------------------------------------- +case14 :: Assertion +case14 = expected + @=? testStep + (step 80 $ Align None WithAlias InlineWithBreak 10 True) expected + where + expected = unlines + [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" + ] + + +-------------------------------------------------------------------------------- +case15 :: Assertion +case15 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 True) input' + where + expected = unlines + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" + ] + + input' = unlines + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" + ] + + +-------------------------------------------------------------------------------- +case16 :: Assertion +case16 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 False) input' + where + expected = unlines + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" + ] + + input' = unlines + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + ] + + +-------------------------------------------------------------------------------- +case17 :: Assertion +case17 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 True) input' + where + expected = unlines + [ "import Control.Applicative (Applicative (pure, (<*>)))" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + ] + + input' = unlines + [ "import Control.Applicative (Applicative ((<*>),pure))" + , "" + , "import Data.Identity (Identity (runIdentity,Identity))" + ] + + +-------------------------------------------------------------------------------- +case18 :: Assertion +case18 = expected @=? testStep + (step 40 $ Align None AfterAlias InlineToMultiline 4 True) input' + where + expected = unlines + ---------------------------------------- + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity" + , " (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + ] + + input' = unlines + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" + ] diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs new file mode 100644 index 0000000..fe889e4 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -0,0 +1,169 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.LanguagePragmas.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.LanguagePragmas +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 + , testCase "case 04" case04 + , testCase "case 05" case05 + , testCase "case 06" case06 + , testCase "case 07" case07 + , testCase "case 08" case08 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 80 Vertical True False) input + where + input = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "module Main where" + ] + + expected = unlines + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step 80 Vertical True True) input + where + input = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + expected = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = expected @=? testStep (step 80 Vertical True True) input + where + input = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] + + expected = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] + + +-------------------------------------------------------------------------------- +case04 :: Assertion +case04 = expected @=? testStep (step 80 Compact True False) input + where + input = unlines + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + + expected = unlines + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell," + , " TypeOperators, ViewPatterns #-}" + ] + + +-------------------------------------------------------------------------------- +case05 :: Assertion +case05 = expected @=? testStep (step 80 Vertical True False) input + where + input = unlines + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] + + expected = unlines + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] + + +-------------------------------------------------------------------------------- +case06 :: Assertion +case06 = expected @=? testStep (step 80 CompactLine True False) input + where + input = unlines + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + expected = unlines + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] + +-------------------------------------------------------------------------------- +case07 :: Assertion +case07 = expected @=? testStep (step 80 Vertical False False) input + where + input = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + expected = unlines + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] + + +-------------------------------------------------------------------------------- +case08 :: Assertion +case08 = expected @=? testStep (step 80 CompactLine False False) input + where + input = unlines + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + expected = unlines + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Records/Tests.hs b/tests/Language/Haskell/Stylish/Step/Records/Tests.hs new file mode 100644 index 0000000..312c6fa --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Records/Tests.hs @@ -0,0 +1,56 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Records.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Records +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Records.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep step input + where + input = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + + expected = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = input @=? testStep step input + where + -- Don't attempt to align this since a field spans multiple lines + input = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux" + , " :: String" + , " } deriving (Show)" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs new file mode 100644 index 0000000..1127a87 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs @@ -0,0 +1,43 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Tabs.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Tabs +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Tabs.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 4) input + where + input = unlines + [ "module Main" + , "\t\twhere" + , "data Foo" + , "\t= Bar" + , " | Qux" + ] + + expected = unlines + [ "module Main" + , " where" + , "data Foo" + , " = Bar" + , " | Qux" + ] diff --git a/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs new file mode 100644 index 0000000..1394edb --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.TrailingWhitespace.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.TrailingWhitespace +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.TrailingWhitespace.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep step input + where + input = unlines + [ "module Main where" + , " " + , "data Foo = Bar | Qux\t " + ] + + expected = unlines + [ "module Main where" + , "" + , "data Foo = Bar | Qux" + ] diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs new file mode 100644 index 0000000..9652350 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.UnicodeSyntax.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.UnicodeSyntax +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step True) input + where + input = unlines + [ "sort :: Ord a => [a] -> [a]" + , "sort _ = []" + ] + + expected = unlines + [ "{-# LANGUAGE UnicodeSyntax #-}" + , "sort ∷ Ord a ⇒ [a] → [a]" + , "sort _ = []" + ] diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs new file mode 100644 index 0000000..40b5629 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -0,0 +1,17 @@ +module Language.Haskell.Stylish.Tests.Util + ( testStep + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Parse +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +testStep :: Step -> String -> String +testStep step str = case parseModule [] Nothing str of + Left err -> error err + Right module' -> unlines $ stepFilter step ls module' + where + ls = lines str diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 index 0000000..28c0603 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,31 @@ +-------------------------------------------------------------------------------- +module Main + ( main + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (defaultMain) + + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.Stylish.Parse.Tests +import qualified Language.Haskell.Stylish.Step.Imports.Tests +import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests +import qualified Language.Haskell.Stylish.Step.Records.Tests +import qualified Language.Haskell.Stylish.Step.Tabs.Tests +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests + + +-------------------------------------------------------------------------------- +main :: IO () +main = defaultMain + [ Language.Haskell.Stylish.Parse.Tests.tests + , Language.Haskell.Stylish.Step.Imports.Tests.tests + , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests + , Language.Haskell.Stylish.Step.Records.Tests.tests + , Language.Haskell.Stylish.Step.Tabs.Tests.tests + , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests + , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests + ] -- cgit v1.2.3