stylish-haskell-0.15.1.0/0000755000000000000000000000000007346545000013245 5ustar0000000000000000stylish-haskell-0.15.1.0/CHANGELOG0000644000000000000000000002464507346545000014472 0ustar0000000000000000# CHANGELOG - 0.15.1.0 (2025-04-13) * #491 Support GHC 9.12 (By GuillaumedeVolpiano) - 0.15.0.1 (2025-04-13) * #493 Support Cabal 3.12 again (By GuillaumedeVolpiano) - 0.15.0.0 (2025-04-13) * #480 Support with GHC 9.10 (By Jan Hrček) * #482 Add `ConfigSearchStrategy` to allow avoiding `getCurrentDirectory` when loading config (by Jan Hrček) This is breaking API change that can be fixed like this: ```diff -format Nothing maybeFile contents +format SearchFromCurrentDirectory maybeFile contents -format (Just cfgFile) maybeFile content +format (UseConfig cfgFile) maybeFile content ``` * Bump `Cabal` lower bound to 3.14 - 0.14.6.0 (2024-01-19) * #471 Support GHC 9.8 (by Michael Peyton Jones) * #440 Fix dissappearing `DEPRECATED` pragma on module (by Lev Dvorkin) * #464 Fix compilation issue with GHC 9.4 - 0.14.5.0 (2023-06-23) * #459 Support GHC 9.6 (by Michael Peyton Jones) * #445 Default `ghc-lib` flag to True (by amesgen) - 0.14.4.0 (2023-01-09) * #421 Support GHC 9.4 (by Lei Zhu) * #439 Fix NoXyz extension issues for .cabal files (by Lev Dvorkin) * #424 Deriving alignment for enums (by Lev Dvorkin) * #416 Support Safe/Trustworthy/Unsafe extensions - 0.14.3.0 (2022-09-28) * Fix parsing of NoXyz extensions * Bump `Cabal` upper bound to 4.0 * Add option to automatically group imports (by Tikhon Jelvis) - 0.14.2.0 (2022-04-27) * Add a build flag to force the use of ghc-lib-parser - 0.14.1.0 (2022-03-31) * Unify the Editor modules, deal with overlap better - 0.14.0.1 (2022-03-17) * Use GHC API directly if >= 9.2.2 * Bump `bytestring` upper bound to 0.12 - 0.14.0.0 (2022-03-16) * Port to GHC 9.2 AST (by jaspervdj) * Case insensitive import sort (by vlatkoB) * Fix issue with dissappearing GADT kind signatures (by Łukasz Gołębiewski) - 0.13.0.0 (2021-09-15) * Don't remove ticks on promoted data types (by Jim McStanton) * Add break_only_where option (by 1Computer1) * Keep wildcard if present in IEThingWith (by Moisés Ackerman) * Generalise break_only_where to allow single-line module headers (by Thomas Winant) * Add new configuration to ModuleHeader step (by Pawel Szulc) * Add a language pragma style "vertical_compact" (by Javran Cheng) * Don't remove existential quantification (by Imuli) * Add support for post qualified import formatting (by Moisés Ackerman) * Bump `optparse-applicative` upper bound to 0.17 - 0.12.2.0 (2020-10-08) * align: Add a new option for aligning only adjacent items (by 1Computer1) * align: Add support for aligning MultiWayIf syntax (by 1Computer1) * data: Fix some issues with record field padding * module_header: Add separate_lists option * imports: Respect separate_lists for (..) imports * data: Make sorting deriving list optional (by Maxim Koltsov) - 0.12.1.0 (2020-10-05) * Bump Cabal-version to 2.4 (by Łukasz Gołębiewski) * Fix "group" import sort with multi-line imports (by Maxim Koltsov) - 0.12.0.0 (2020-10-02) * Use ghc-lib-parser rather than haskell-src-exts This patch swaps out the parsing library from `haskell-src-exts` to `ghc-lib-parser`, which gives us better compatibility with GHC. Because almost every module heavily used the Haskell AST provided by `haskell-src-exts`, this was a huge effort and it would not have been possible without Felix Mulder doing an initial port, GSoC student Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and Paweł Szulc who helped me finish up things in the home stretch. I've generally tried to keep styling 100% compatible with what was there before, but some issues may have unintentionally slipped in so please report those. This introduces one new import styling contributed by Felix: when wrapping import lists over multiple lines, you can repeat the module name, e.g.: import Control.Monad.Except as X (ExceptT (..), MonadError (..)) import Control.Monad.Except as X (runExceptT, withExceptT) This is activated by using `import_align: repeat`. Secondly, a new Step was added, `module_header`, which formats the export list of a module, including the trailing `where` clause. Details for this new step can be found in the `data/stylish-haskell.yaml`. * Remove `semigroup` dependency for GHC >= 8.0 * Bump `strict` upper bound to 0.4 * Bump `Cabal` upper bound to 3.3 for test suite - 0.11.0.3 (2020-08-02) * Set default-language to Haskell2010 - 0.11.0.2 (2020-08-02) * Bump `Cabal-version` to 1.10 - 0.11.0.1 (2020-08-02) * Bump `aeson` upper bound to 1.6 * Bump `Cabal` upper bound to 3.3 - 0.11.0.0 (2020-02-24) * Disable record formatting by default * Allow more customization for record formatting (by Maxim Koltsov) * Disable formatting of data types without records (by Maxim Koltsov) * Add `-r` flag to recursively find Haskell files (by Akos Marton) - 0.10.0.0 (2020-01-26) * Switch to HsYAML library (by vijayphoenix) * Expose `format` from main library (by Łukasz Gołębiewski) * Support record formatting (by Łukasz Gołębiewski and Pawel Szulc) * Allow setting `columns` to `null` to disable all wrapping (by Chris Martin) * Bump `haskell-src-exts` to 1.23 * New logo (by Jose Fernando García Parreño) * Make language extension prefix configurable (by Flavio Corpa) - 0.9.4.4 (2019-11-03) * Bump `haskell-src-exts` to 1.22 - 0.9.4.3 (2019-10-29) * Bump release script * Bump `Cabal` to 3.0 - 0.9.4.2 (2019-10-29) * Bump release script - 0.9.4.1 (2019-10-29) * Bump release script - 0.9.4.0 (2019-10-29) * Read language extensions from `.cabal` file (by Georgy Lukyanov) - 0.9.3.1 (2019-10-08) * Fix CircleCI configuration - 0.9.3.0 (2019-10-08) * Bump `optparse-applicative` to 0.15 * Don't remove page breaks in the trailing whitespace step (by Chris Perivolaropoulos) * Add `with_module_name` option to `list_align` for import styling (by Rupert Horlick) - 0.9.2.2 (2019-06-12) * Bump `semigroups` to 0.19 * Bump `haskell-src-exts` to 1.21 - 0.9.2.1 (2019-01-02) * Bump `aeson` to 1.4 * Bump `yaml` to 0.11 * Bump `containers` to 0.6 - 0.9.2.0 (2018-05-01) * Support alignment of case expressions with a single guard * Add a new step to squash multiple spaces between some elements (by Martin Huschenbett) - 0.9.1.1 (2018-04-26) * Bump `aeson` to 1.3 for tests as well - 0.9.1.0 (2018-04-26) * Support GHC 8.4.1 by adding instance SemiGroup ImportPortion (by George Wilson) * Bump `aeson` to 1.3 - 0.9.0.2 (2018-01-03) * Bump lower bound of `directory` to `1.2.3` for `getXdgDirectory` - 0.9.0.1 (2017-12-29) * Fix missing Extra-source-file in cabal file - 0.9.0.0 (2017-12-26) * Embed the default configuration * Add platform-specific configuration paths (by Jan Tojnar) * Bump `haskell-src-exts` to 0.20 * Avoid unpaired parenthesis when import doesn't specify any items (by Matthew Kennerly) * Remove shebang lines at the beginning of file (by Vaibhav Sagar) - 0.8.1.0 (2017-06-19) * Add `pad_module_names` option (by Yuriy Syrovetskiy) * Add `space_surround` option to import styling (by Linus Arver) * Bump `optparse-applicative` to 0.14 - 0.8.0.0 * Remove `MagicHash` from whitelisted language extensions, since it was causing parsing errors (by Artyom Kazak) * Don't leave a `#-}` hanging on the next line when `language_pragmas` is set to `compact` and the `#-}` doesn't fit into character limit (by Artyom Kazak) * Deduplicate import specs (i.e. `import Foo (a, a, b)` becomes `import Foo (a, b)`) (by Artyom Kazak) * Take package imports into account when prettifying imports (by Artyom Kazak) * Bump `aeson` to 1.2 * Bump `syb` to 0.7 * Bump `HUnit` to 1.6 - 0.7.1.0 * Keep `safe` and `{-# SOURCE #-}` import annotations (by Moritz Drexl) - 0.7.0.0 * If there's parse errors, show these and exit with code 1 * Bump `aeson` to 1.1 * Bump `directory` to 1.3 * Bump `haskell-src-exts` to 1.19 - 0.6.5.0 * Fix issue with unit records (by Mizunashi Mana) * Bump `HUnit` to 1.5 - 0.6.4.0 * Remove `XmlSyntax` from whitelisted language extensions, since it was causing parsing errors - 0.6.3.0 * Bump `optparse-applicative` to 0.13.0.0 * Export Import options & add a default * Add `list_padding: module_name` option (by Oleg Grenrus) * Bump `aeson` to 1.0 (by Oleg Grenrus) * Special setting for empty import lists (by Oleg Grenrus) - 0.6.2.0 * Bump `haskell-src-exts` to 1.18 - 0.6.1.0 * Fix line patching issue in Editor - 0.6.0.0 * Add a `simple_align` step * Move `records` step into `simple_align` * Use a set of default language extensions for parsing (by Langston Barrett) * Add a newline format option (by Svyatolslav Gryaznov) * Add more symbols from UnicodeSyntax (by Langston Barrett) * Add a `--version` option (by Ondra Pelech) - 0.5.17.0 * Remove shebang from input before attempting to extract pragmas * Set stdin and stdout encoding to UTF-8 by default - 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 stylish-haskell-0.15.1.0/LICENSE0000644000000000000000000000314507346545000014255 0ustar0000000000000000Copyright (c) 2012, Jasper Van der Jeugt Copyright (c) 2016, 2018 Sean Whitton 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. stylish-haskell-0.15.1.0/README.markdown0000644000000000000000000001633007346545000015751 0ustar0000000000000000## stylish-haskell ![Stack Build Status](https://github.com/jaspervdj/stylish-haskell/workflows/CI/badge.svg) ![Cabal Build Status](https://github.com/jaspervdj/stylish-haskell/workflows/Cabal/badge.svg) ## 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. ## Installation You can install it using `stack install stylish-haskell` or `cabal install stylish-haskell`. You can also install it using your package manager: - Debian 9 or later: `apt-get install stylish-haskell` - Ubuntu 16.10 or later: `apt-get install stylish-haskell` - Arch Linux: `pacman -S stylish-haskell` ## Features - Aligns and sorts `import` statements - Groups and wraps `{-# LANGUAGE #-}` pragmas, can remove (some) redundant pragmas - Removes trailing whitespace - Aligns branches in `case` and fields in records - Converts line endings (customizable) - Replaces tabs by four spaces (turned off by default) - Replaces some ASCII sequences by their Unicode equivalents (turned off by default) - Format data constructors and fields in records. Feature requests are welcome! Use the [issue tracker] for that. [issue tracker]: https://github.com/haskell/stylish-haskell/issues ## Example Turns: ```haskell {-# 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: ```haskell {-# 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/config.yaml` in the platform’s configuration directory (on Windows, it is %APPDATA%, elsewhere it defaults to `~/.config` and can be overridden by the `XDG_CONFIG_HOME` environment variable; useful for user-wide settings) 5. `.stylish-haskell.yaml` in your home directory (useful for user-wide settings) 6. 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. ## Record formatting Basically, stylish-haskell supports 4 different styles of records, controlled by `records` in the config file. Here's an example of all four styles: ```haskell -- equals: "indent 2", "first_field": "indent 2" data Foo a = Foo { a :: Int , a2 :: String -- ^ some haddock } | Bar { b :: a } deriving (Eq, Show) deriving (ToJSON) via Bar Foo -- equals: "same_line", "first_field": "indent 2" data Foo a = Foo { a :: Int , a2 :: String -- ^ some haddock } | Bar { b :: a } deriving (Eq, Show) deriving (ToJSON) via Bar Foo -- equals: "same_line", "first_field": "same_line" data Foo a = Foo { a :: Int , a2 :: String -- ^ some haddock } | Bar { b :: a } deriving (Eq, Show) deriving (ToJSON) via Bar Foo -- equals: "indent 2", first_field: "same_line" data Foo a = Foo { a :: Int , a2 :: String -- ^ some haddock } | Bar { b :: a } deriving (Eq, Show) deriving (ToJSON) via Bar Foo ``` ## Editor integration ### Haskell Language Server [Haskell Language Server(HLS)][HLS] includes a [plugin][HLS stylish-haskell Plugin] for stylish-haskell. By changing the formatting provider option (`haskell.formattingProvider`) to `stylish-haskell` as described in [HLS options][HLS option], any editors that support [Language Server Protocol][LSP] can use stylish-haskell for formatting. [HLS]: https://github.com/haskell/haskell-language-server [HLS option]: https://haskell-language-server.readthedocs.io/en/latest/configuration.html#language-specific-server-options [HLS stylish-haskell Plugin]: https://github.com/haskell/haskell-language-server/blob/master/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs [LSP]: https://microsoft.github.io/language-server-protocol/ ### VIM integration Since it works as a filter it is pretty easy to integrate this with VIM. You can call :%!stylish-haskell and add a keybinding for it. Or you can define `formatprg` :set formatprg=stylish-haskell and then use `gq`. Alternatively, [vim-autoformat] supports stylish-haskell. To have it automatically reformat the files on save, add to your vimrc: ```vim autocmd BufWrite *.hs :Autoformat " Don't automatically indent on save, since vim's autoindent for haskell is buggy autocmd FileType haskell let b:autoformat_autoindent=0 ``` There are also plugins that run stylish-haskell automatically when you save a Haskell file: - [vim-stylish-haskell] - [vim-stylishask] [vim-stylish-haskell]: https://github.com/nbouscal/vim-stylish-haskell [vim-stylishask]: https://github.com/alx741/vim-stylishask ### Emacs integration [haskell-mode] for Emacs supports `stylish-haskell`. For configuration, see [the “Using external formatters” section][haskell-mode/format] of the haskell-mode manual. [haskell-mode]: https://github.com/haskell/haskell-mode [haskell-mode/format]: http://haskell.github.io/haskell-mode/manual/latest/Autoformating.html ### Atom integration [ide-haskell] for Atom supports `stylish-haskell`. [atom-beautify] for Atom supports Haskell using `stylish-haskell`. [ide-haskell]: https://atom.io/packages/ide-haskell [atom-beautify]: Https://atom.io/packages/atom-beautify ### Visual Studio Code integration [stylish-haskell-vscode] for VSCode supports `stylish-haskell`. [stylish-haskell-vscode]: https://github.com/vigoo/stylish-haskell-vscode ## Using with Continuous Integration You can quickly grab the latest binary and run `stylish-haskell` like so: curl -sL https://raw.github.com/haskell/stylish-haskell/master/scripts/latest.sh | sh -s . Where the `.` can be replaced with the arguments you pass to `stylish-haskell`. ## Credits Written and maintained by Jasper Van der Jeugt. Contributors: - Chris Done - Hiromi Ishii - Leonid Onokhov - Michael Snoyman - Mikhail Glushenkov - Beatrice Vergani - Paweł Szulc - Łukasz Gołębiewski - Felix Mulder stylish-haskell-0.15.1.0/Setup.hs0000644000000000000000000000005607346545000014702 0ustar0000000000000000import Distribution.Simple main = defaultMain stylish-haskell-0.15.1.0/data/0000755000000000000000000000000007346545000014156 5ustar0000000000000000stylish-haskell-0.15.1.0/data/stylish-haskell.yaml0000644000000000000000000004241307346545000020166 0ustar0000000000000000# 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 # Format module header # # Currently, this option is not configurable and will format all exports and # module declarations to minimize diffs # # - module_header: # # How many spaces use for indentation in the module header. # indent: 4 # # # Should export lists be sorted? Sorting is only performed within the # # export section, as delineated by Haddock comments. # sort: true # # # See `separate_lists` for the `imports` step. # separate_lists: true # # # When to break the "where". # # Possible values: # # - exports: only break when there is an explicit export list. # # - single: only break when the export list counts more than one export. # # - inline: only break when the export list is too long. This is # # determined by the `columns` setting. Not applicable when the export # # list contains comments as newlines will be required. # # - always: always break before the "where". # break_where: exports # # # Where to put open bracket # # Possible values: # # - same_line: put open bracket on the same line as the module name, before the # # comment of the module # # - next_line: put open bracket on the next line, after module comment # open_bracket: next_line # Format record definitions. This is disabled by default. # # You can control the layout of record fields. The only rules that can't be configured # are these: # # - "|" is always aligned with "=" # - "," in fields is always aligned with "{" # - "}" is likewise always aligned with "{" # # - records: # # How to format equals sign between type constructor and data constructor. # # Possible values: # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. # equals: "indent 2" # # # How to format first field of each record constructor. # # Possible values: # # - "same_line" -- "{" and first field goes on the same line as the data constructor. # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor # first_field: "indent 2" # # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. # field_comment: 2 # # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. # deriving: 2 # # # How many spaces to insert before "via" clause counted from indentation of deriving clause # # Possible values: # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. # via: "indent 2" # # # Sort typeclass names in the "deriving" list alphabetically. # sort_deriving: true # # # Whether or not to break enums onto several lines # # # # Default: false # break_enums: false # # # Whether or not to break single constructor data types before `=` sign # # # # Default: true # break_single_constructors: true # # # Whether or not to curry constraints on function. # # # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ # # # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ # # # # Default: false # curried_context: false # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single # line. # Possible values: # - always - Always align statements. # - adjacent - Align statements that are on adjacent lines in groups. # - never - Never align statements. # All default to always. - simple_align: cases: always top_level_patterns: always records: always multi_way_if: always # 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 # The following 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) # # - with_module_name: Import list is aligned `list_padding` spaces after # the module name. # # > import qualified Data.List as List (concat, foldl, foldr, head, # init, last, length) # # This is mainly intended for use with `pad_module_names: false`. # # > import qualified Data.List as List (concat, foldl, foldr, head, # init, last, length, scanl, scanr, take, drop, # sort, nub) # # - new_line: Import list starts always on new line. # # > import qualified Data.List as List # > (concat, foldl, foldr, head, init, last, length) # # - repeat: Repeat the module name to align the import list. # # > import qualified Data.List as List (concat, foldl, foldr, head) # > import qualified Data.List as List (init, last, length) # # Default: after_alias list_align: after_alias # Right-pad the module names to align imports in a group: # # - true: a little more readable # # > import qualified Data.List as List (concat, foldl, foldr, # > init, last, length) # > import qualified Data.List.Extra as List (concat, foldl, foldr, # > init, last, length) # # - false: diff-safe # # > import qualified Data.List as List (concat, foldl, foldr, init, # > last, length) # > import qualified Data.List.Extra as List (concat, foldl, foldr, # > init, last, length) # # Default: true pad_module_names: true # 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 constructor list acts like single import. # # > import qualified Data.Map as M # > ( empty # > , singleton # > , ... # > , delete # > ) # # Default: inline long_list_align: inline # Align empty list (importing instances) # # Empty list align has following options # # - inherit: inherit list_align setting # # - right_after: () is right after the module name: # # > import Vector.Instances () # # Default: inherit empty_list_align: inherit # List padding determines indentation of import list on lines after import. # This option affects 'long_list_align'. # # - : constant value # # - module_name: align under start of module name. # Useful for 'file' and 'group' align settings. # # Default: 4 list_padding: 4 # Separate lists option affects formatting 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 # Space surround option affects formatting of import lists on a single # line. The only difference is single space after the initial # parenthesis and a single space before the terminal parenthesis. # # - true: There is single space associated with the enclosing # parenthesis. # # > import Data.Foo ( foo ) # # - false: There is no space associated with the enclosing parenthesis # # > import Data.Foo (foo) # # Default: false space_surround: false # Post qualify option moves any qualifies found in import declarations # to the end of the declaration. This also adjust padding for any # unqualified import declarations. # # - true: Qualified as is moved to the end of the # declaration. # # > import Data.Bar # > import Data.Foo qualified as F # # - false: Qualified remains in the default location and unqualified # imports are padded to align with qualified imports. # # > import Data.Bar # > import qualified Data.Foo as F # # Default: false post_qualify: false # Automatically group imports based on their module names, with # a blank line separating each group. Groups are ordered in # alphabetical order. # # By default, this groups by the first part of each module's # name (Control.* will be grouped together, Data.*... etc), but # this can be configured with the group_patterns setting. # # When enabled, this rewrites existing blank lines and groups. # # - true: Group imports by the first part of the module name. # # > import Control.Applicative # > import Control.Monad # > import Control.Monad.MonadError # > # > import Data.Functor # # - false: Keep import groups as-is (still sorting and # formatting the imports within each group) # # > import Control.Monad # > import Data.Functor # > # > import Control.Applicative # > import Control.Monad.MonadError # # Default: false group_imports: false # A list of rules specifying how to group modules and how to # order the groups. # # Each rule has a match field; the rule only applies to module # names matched by this pattern. Patterns are POSIX extended # regular expressions; see the documentation of Text.Regex.TDFA # for details: # https://hackage.haskell.org/package/regex-tdfa-1.3.1.2/docs/Text-Regex-TDFA.html # # Rules are processed in order, so only the *first* rule that # matches a specific module will apply. Any module names that do # not match a single rule will be put into a single group at the # end of the import block. # # Example: group MyApp modules first, with everything else in # one group at the end. # # group_rules: # - match: "^MyApp\\>" # # > import MyApp # > import MyApp.Foo # > # > import Control.Monad # > import MyApps # > import Test.MyApp # # A rule can also optionally have a sub_group pattern. Imports # that match the rule will be broken up into further groups by # the part of the module name matched by the sub_group pattern. # # Example: group MyApp modules first, then everything else # sub-grouped by the first part of the module name. # # group_rules: # - match: "^MyApp\\>" # - match: "." # sub_group: "^[^.]+" # # > import MyApp # > import MyApp.Foo # > # > import Control.Applicative # > import Control.Monad # > # > import Data.Map # # A pattern only needs to match part of the module name, which # could be in the middle. You can use ^pattern to anchor to the # beginning of the module name, pattern$ to anchor to the end # and ^pattern$ to force a full match. Example: # # - "Test\\." would match "Test.Foo" and "Foo.Test.Lib" # - "^Test\\." would match "Test.Foo" but not "Foo.Test.Lib" # - "\\.Test$" would match "Foo.Test" but not "Foo.Test.Lib" # - "^Test$" would *only* match "Test" # # You can use \\< and \\> to anchor against the beginning and # end of words, respectively. For example: # # - "^Test\\." would match "Test.Foo" but not "Test" or "Tests" # - "^Test\\>" would match "Test.Foo" and "Test", but not # "Tests" # # The default is a single rule that matches everything and # sub-groups based on the first component of the module name. # # Default: [{ "match" : ".*", "sub_group": "^[^.]+" }] group_rules: - match: ".*" sub_group: "^[^.]+" # 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 #-}'. # # - vertical_compact: Similar to vertical, but use only one language pragma. # # Default: vertical. style: vertical # Align affects alignment of closing pragma brackets. # # - true: Brackets are aligned in same column. # # - 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 # Language prefix to be used for pragma declaration, this allows you to # use other options non case-sensitive like "language" or "Language". # If a non correct String is provided, it will default to: LANGUAGE. language_prefix: LANGUAGE # 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: {} # Squash multiple spaces between the left and right hand sides of some # elements into single spaces. Basically, this undoes the effect of # simple_align but is a bit less conservative. # - squash: {} # A common setting is the number of columns (parts of) code will be wrapped # to. Different steps take this into account. # # Set this to null to disable all line wrapping. # # Default: 80. columns: 80 # By default, line endings are converted according to the OS. You can override # preferred format here. # # - native: Native newline format. CRLF on Windows, LF on other OSes. # # - lf: Convert to LF ("\n"). # # - crlf: Convert to CRLF ("\r\n"). # # Default: native. newline: native # 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 # Attempt to find the cabal file in ancestors of the current directory, and # parse options (currently only language extensions) from that. # # Default: true cabal: true stylish-haskell-0.15.1.0/lib/Language/Haskell/0000755000000000000000000000000007346545000017121 5ustar0000000000000000stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish.hs0000644000000000000000000001273407346545000021123 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish ( -- * Run runSteps -- * Steps , simpleAlign , imports , languagePragmas , tabs , trailingWhitespace , unicodeSyntax -- ** Helpers , findHaskellFiles , stepName -- * Config , module Language.Haskell.Stylish.Config -- * Misc , module Language.Haskell.Stylish.Verbose , version , format , ConfigSearchStrategy(..) , Lines , Step ) where -------------------------------------------------------------------------------- import Control.Monad (foldM) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (takeExtension, ()) -------------------------------------------------------------------------------- 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.SimpleAlign as SimpleAlign 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) -------------------------------------------------------------------------------- simpleAlign :: Maybe Int -- ^ Columns -> SimpleAlign.Config -> Step simpleAlign = SimpleAlign.step -------------------------------------------------------------------------------- imports :: Maybe Int -- ^ columns -> Imports.Options -> Step imports = Imports.step -------------------------------------------------------------------------------- languagePragmas :: Maybe Int -- ^ columns -> LanguagePragmas.Style -> Bool -- ^ Pad to same length in vertical mode? -> Bool -- ^ remove redundant? -> String -- ^ language prefix -> Step languagePragmas = LanguagePragmas.step -------------------------------------------------------------------------------- tabs :: Int -- ^ number of spaces -> Step tabs = Tabs.step -------------------------------------------------------------------------------- trailingWhitespace :: Step trailingWhitespace = TrailingWhitespace.step -------------------------------------------------------------------------------- unicodeSyntax :: Bool -- ^ add language pragma? -> String -- ^ language prefix -> Step unicodeSyntax = UnicodeSyntax.step -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls = \case Step _name step -> step ls <$> parseModule exts mfp (unlines ls) -------------------------------------------------------------------------------- runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines -> Either String Lines runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps -- | Formats given contents. format :: ConfigSearchStrategy -> Maybe FilePath -- ^ the location from which the contents to format were read. -- If provided, it's going to be printed out in the error message. -> String -- ^ the contents to format -> IO (Either String Lines) format configSearchStrategy maybeFilePath contents = do conf <- loadConfig (makeVerbose True) configSearchStrategy pure $ runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) $ lines contents -------------------------------------------------------------------------------- -- | Searches Haskell source files in any given folder recursively. findHaskellFiles :: Bool -> [FilePath] -> IO [FilePath] findHaskellFiles v fs = mapM (findFilesR v) fs >>= return . concat -------------------------------------------------------------------------------- findFilesR :: Bool -> FilePath -> IO [FilePath] findFilesR _ [] = return [] findFilesR v path = do doesFileExist path >>= \case True -> return [path] _ -> doesDirectoryExist path >>= \case True -> findFilesRecursive path >>= return . filter (\x -> takeExtension x == ".hs") False -> do makeVerbose v ("Input folder does not exists: " <> path) findFilesR v [] where findFilesRecursive :: FilePath -> IO [FilePath] findFilesRecursive = listDirectoryFiles findFilesRecursive listDirectoryFiles :: (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath] listDirectoryFiles go topdir = do ps <- listDirectory topdir >>= mapM (\x -> do let dir = topdir x doesDirectoryExist dir >>= \case True -> go dir False -> return [dir]) return $ concat ps stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/0000755000000000000000000000000007346545000020560 5ustar0000000000000000stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Align.hs0000644000000000000000000000677407346545000022164 0ustar0000000000000000-------------------------------------------------------------------------------- -- | This module is useful for aligning things. module Language.Haskell.Stylish.Align ( Alignable (..) , align ) where -------------------------------------------------------------------------------- import Data.List (nub) import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -- | This represent a single line which can be aligned. We have something on -- the left and the right side, e.g.: -- -- > [x] -> x + 1 -- > ^^^^ ^^^^^ -- > LEFT RIGHT -- -- We also have the container which holds the entire line: -- -- > [x] -> x + 1 -- > ^^^^^^^^^^^^^ -- > CONTAINER -- -- And then we have a "right lead" which is just represented by an 'Int', since -- @haskell-src-exts@ often does not allow us to access it. In the example this -- is: -- -- > [x] -> x + 1 -- > ^^^ -- > RLEAD -- -- This info is enough to align a bunch of these lines. Users of this module -- should construct a list of 'Alignable's representing whatever they want to -- align, and then call 'align' on that. data Alignable a = Alignable { aContainer :: !a , aLeft :: !a , aRight :: !a -- | This is the minimal number of columns we need for the leading part not -- included in our right string. For example, for datatype alignment, this -- leading part is the string ":: " so we use 3. , aRightLead :: !Int } deriving (Show) -------------------------------------------------------------------------------- -- | Create changes that perform the alignment. align :: Maybe Int -- ^ Max columns -> [Alignable GHC.RealSrcSpan] -- ^ Alignables -> Editor.Edits -- ^ Changes performing the alignment align _ [] = mempty align maxColumns alignment -- Do not make an changes if we would go past the maximum number of columns | exceedsColumns (longestLeft + longestRight) = mempty | not (fixable alignment) = mempty | otherwise = foldMap align' alignment where exceedsColumns i = case maxColumns of Nothing -> False Just c -> i > c -- The longest thing in the left column longestLeft = maximum $ map (GHC.srcSpanEndCol . aLeft) alignment -- The longest thing in the right column longestRight = maximum [ GHC.srcSpanEndCol (aRight a) - GHC.srcSpanStartCol (aRight a) + aRightLead a | a <- alignment ] align' a = Editor.changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str -> let column = GHC.srcSpanEndCol $ aLeft a (pre, post) = splitAt column str in [padRight longestLeft (trimRight pre) ++ trimLeft post] -------------------------------------------------------------------------------- -- | Checks that all the alignables appear on a single line, and that they do -- not overlap. fixable :: [Alignable GHC.RealSrcSpan] -> Bool fixable [] = False fixable [_] = False fixable fields = all singleLine containers && nonOverlapping containers where containers = map aContainer fields singleLine s = GHC.srcSpanStartLine s == GHC.srcSpanEndLine s nonOverlapping ss = length ss == length (nub $ map GHC.srcSpanStartLine ss) stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Block.hs0000644000000000000000000000606007346545000022150 0ustar0000000000000000-------------------------------------------------------------------------------- module Language.Haskell.Stylish.Block ( Block (..) , LineBlock , realSrcSpanToLineBlock , SpanBlock , blockLength , moveBlock , adjacent , merge , mergeAdjacent , overlapping , groupAdjacent ) where -------------------------------------------------------------------------------- import qualified Data.IntSet as IS import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- -- | Indicates a line span data Block a = Block { blockStart :: Int , blockEnd :: Int } deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- instance Semigroup (Block a) where (<>) = merge -------------------------------------------------------------------------------- type LineBlock = Block String -------------------------------------------------------------------------------- type SpanBlock = Block Char -------------------------------------------------------------------------------- realSrcSpanToLineBlock :: GHC.RealSrcSpan -> Block String realSrcSpanToLineBlock s = Block (GHC.srcSpanStartLine s) (GHC.srcSpanEndLine s) -------------------------------------------------------------------------------- blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 -------------------------------------------------------------------------------- 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 == 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 = go IS.empty where go _ [] = False go acc (b : bs) = let ints = [blockStart b .. blockEnd b] in if any (`IS.member` acc) ints then True else go (IS.union acc $ IS.fromList ints) bs -------------------------------------------------------------------------------- -- | 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) mergeAdjacent :: [Block a] -> [Block a] mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest mergeAdjacent (a : rest) = a : mergeAdjacent rest mergeAdjacent [] = [] stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Comments.hs0000644000000000000000000001317607346545000022711 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Utilities for assocgating comments with things in a list. {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Stylish.Comments ( CommentGroup (..) , commentGroups , commentGroupHasComments , commentGroupSort ) where -------------------------------------------------------------------------------- import Data.Function (on) import Data.List (sortBy, sortOn) import Data.Maybe (isNothing, maybeToList) import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.GHC -------------------------------------------------------------------------------- data CommentGroup a = CommentGroup { cgBlock :: LineBlock , cgPrior :: [GHC.LEpaComment] , cgItems :: [(a, Maybe GHC.LEpaComment)] , cgFollowing :: [GHC.LEpaComment] } -------------------------------------------------------------------------------- instance GHC.Outputable a => Show (CommentGroup a) where show CommentGroup {..} = "(CommentGroup (" ++ show cgBlock ++ ") (" ++ showOutputable cgPrior ++ ") (" ++ showOutputable cgItems ++ ") (" ++ showOutputable cgFollowing ++ "))" -------------------------------------------------------------------------------- commentGroups :: forall a. (a -> Maybe GHC.RealSrcSpan) -> [a] -> [GHC.LEpaComment] -> [CommentGroup a] commentGroups getSpan allItems allComments = work Nothing (sortOn fst allItemsWithLines) (sortOn fst commentsWithLines) where allItemsWithLines :: [(LineBlock, a)] allItemsWithLines = do item <- allItems s <- maybeToList $ getSpan item pure (realSrcSpanToLineBlock s, item) commentsWithLines :: [(LineBlock, GHC.LEpaComment)] commentsWithLines = do comment <- allComments let s = GHC.epaLocationRealSrcSpan $ GHC.getLoc comment pure (realSrcSpanToLineBlock s, comment) work :: Maybe (CommentGroup a) -> [(LineBlock, a)] -> [(LineBlock, GHC.LEpaComment)] -> [CommentGroup a] work mbCurrent items comments = case takeNext items comments of Nothing -> maybeToList mbCurrent Just (b, next, items', comments') -> let (flush, current) = case mbCurrent of Just c | adjacent (cgBlock c) b , nextThingItem next , following@(_ : _) <- cgFollowing c -> ([c {cgFollowing = []}], CommentGroup b following [] []) Just c | adjacent (cgBlock c) b -> ([], c {cgBlock = cgBlock c <> b}) _ -> (maybeToList mbCurrent, CommentGroup b [] [] []) current' = case next of NextItem i -> current {cgItems = cgItems current <> [(i, Nothing)]} NextComment c | null (cgItems current) -> current {cgPrior = cgPrior current <> [c]} | otherwise -> current {cgFollowing = cgFollowing current <> [c]} NextItemWithComment i c -> current {cgItems = cgItems current <> [(i, Just c)]} in flush ++ work (Just current') items' comments' -------------------------------------------------------------------------------- takeNext :: [(LineBlock, a)] -> [(LineBlock, GHC.LEpaComment)] -> Maybe (LineBlock, NextThing a, [(LineBlock, a)], [(LineBlock, GHC.LEpaComment)]) takeNext [] [] = Nothing takeNext [] ((cb, c) : comments) = Just (cb, NextComment c, [], comments) takeNext ((ib, i) : items) [] = Just (ib, NextItem i, items, []) takeNext ((ib, i) : items) ((cb, c) : comments) | blockStart ib == blockStart cb = Just (ib <> cb, NextItemWithComment i c, items, comments) | blockStart ib < blockStart cb = Just (ib, NextItem i, items, (cb, c) : comments) | otherwise = Just (cb, NextComment c, (ib, i) : items, comments) -------------------------------------------------------------------------------- data NextThing a = NextComment GHC.LEpaComment | NextItem a | NextItemWithComment a GHC.LEpaComment -------------------------------------------------------------------------------- instance GHC.Outputable a => Show (NextThing a) where show (NextComment c) = "NextComment " ++ showOutputable c show (NextItem i) = "NextItem " ++ showOutputable i show (NextItemWithComment i c) = "NextItemWithComment " ++ showOutputable i ++ " " ++ showOutputable c -------------------------------------------------------------------------------- nextThingItem :: NextThing a -> Bool nextThingItem (NextComment _) = False nextThingItem (NextItem _) = True nextThingItem (NextItemWithComment _ _) = True -------------------------------------------------------------------------------- commentGroupHasComments :: CommentGroup a -> Bool commentGroupHasComments CommentGroup {..} = not $ null cgPrior && all (isNothing . snd) cgItems && null cgFollowing -------------------------------------------------------------------------------- commentGroupSort :: (a -> a -> Ordering) -> CommentGroup a -> CommentGroup a commentGroupSort cmp cg = cg { cgItems = sortBy (cmp `on` fst) (cgItems cg) } stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Config.hs0000644000000000000000000004006607346545000022327 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Stylish.Config ( Extensions , Config (..) , ConfigSearchStrategy (..) , ExitCodeBehavior (..) , defaultConfigBytes , configFilePath , loadConfig , parseConfig ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) 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.ByteString.Lazy (fromStrict) import Data.Char (toLower) import qualified Data.FileEmbed as FileEmbed import Data.List (intercalate, nub) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.YAML (prettyPosWithSource) import Data.YAML.Aeson (decode1Strict) import System.Directory import System.FilePath (()) import qualified System.IO as IO (Newline (..), nativeNewline) import Text.Read (readMaybe) -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Config.Cabal as Cabal import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash import qualified Language.Haskell.Stylish.Step.Tabs as Tabs import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax import Language.Haskell.Stylish.Verbose -------------------------------------------------------------------------------- type Extensions = [String] -------------------------------------------------------------------------------- data Config = Config { configSteps :: [Step] , configColumns :: Maybe Int , configLanguageExtensions :: [String] , configNewline :: IO.Newline , configCabal :: Bool , configExitCode :: ExitCodeBehavior } -------------------------------------------------------------------------------- data ExitCodeBehavior = NormalExitBehavior | ErrorOnFormatExitBehavior deriving (Eq) instance Show ExitCodeBehavior where show NormalExitBehavior = "normal" show ErrorOnFormatExitBehavior = "error_on_format" -------------------------------------------------------------------------------- instance FromJSON Config where parseJSON = parseConfig -------------------------------------------------------------------------------- configFileName :: String configFileName = ".stylish-haskell.yaml" -------------------------------------------------------------------------------- defaultConfigBytes :: B.ByteString defaultConfigBytes = $(FileEmbed.embedFile "data/stylish-haskell.yaml") -------------------------------------------------------------------------------- configFilePath :: Verbose -> ConfigSearchStrategy -> IO (Maybe FilePath) configFilePath _ (UseConfig userSpecified) = return (Just userSpecified) configFilePath verbose (SearchFromDirectory dir) = searchFrom verbose dir configFilePath verbose SearchFromCurrentDirectory = searchFrom verbose =<< getCurrentDirectory searchFrom :: Verbose -> FilePath -> IO (Maybe FilePath) searchFrom verbose startDir = do configPath <- getXdgDirectory XdgConfig "stylish-haskell" home <- getHomeDirectory search verbose $ [d configFileName | d <- ancestors startDir] ++ [configPath "config.yaml", home configFileName] search :: Verbose -> [FilePath] -> IO (Maybe FilePath) search _ [] = return Nothing search verbose (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 verbose fs -------------------------------------------------------------------------------- loadConfig :: Verbose -> ConfigSearchStrategy -> IO Config loadConfig verbose configSearchStrategy = do mbFp <- configFilePath verbose configSearchStrategy verbose $ "Loading configuration at " ++ fromMaybe "" mbFp bytes <- maybe (return defaultConfigBytes) B.readFile mbFp case decode1Strict bytes of Left (pos, err) -> error $ prettyPosWithSource pos (fromStrict bytes) ("Language.Haskell.Stylish.Config.loadConfig: " ++ err) Right config -> do cabalLanguageExtensions <- if configCabal config then map toStr <$> Cabal.findLanguageExtensions verbose configSearchStrategy else pure [] return $ config { configLanguageExtensions = nub $ configLanguageExtensions config ++ cabalLanguageExtensions } where toStr (ext, True) = show ext toStr (ext, False) = "No" ++ show ext -------------------------------------------------------------------------------- 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..!= Just 80) <*> (o A..:? "language_extensions" A..!= []) <*> (o A..:? "newline" >>= parseEnum newlines IO.nativeNewline) <*> (o A..:? "cabal" A..!= True) <*> (o A..:? "exit_code" >>= parseEnum exitCodes NormalExitBehavior) -- Then fill in the steps based on the partial config we already have stepValues <- o A..: "steps" :: A.Parser [A.Value] steps <- mapM (parseSteps config) stepValues return config {configSteps = concat steps} where newlines = [ ("native", IO.nativeNewline) , ("lf", IO.LF) , ("crlf", IO.CRLF) ] exitCodes = [ ("normal", NormalExitBehavior) , ("error_on_format", ErrorOnFormatExitBehavior) ] parseConfig _ = mzero -------------------------------------------------------------------------------- catalog :: Map String (Config -> A.Object -> A.Parser Step) catalog = M.fromList [ ("imports", parseImports) , ("module_header", parseModuleHeader) , ("records", parseRecords) , ("language_pragmas", parseLanguagePragmas) , ("simple_align", parseSimpleAlign) , ("squash", parseSquash) , ("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) -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step parseModuleHeader config o = fmap (ModuleHeader.step columns) $ ModuleHeader.Config <$> (o A..:? "indent" A..!= ModuleHeader.indent def) <*> (o A..:? "sort" A..!= ModuleHeader.sort def) <*> (o A..:? "separate_lists" A..!= ModuleHeader.separateLists def) <*> (o A..:? "break_where" >>= parseEnum breakWhere (ModuleHeader.breakWhere def)) <*> (o A..:? "open_bracket" >>= parseEnum openBracket (ModuleHeader.openBracket def)) where def = ModuleHeader.defaultConfig columns = configColumns config breakWhere = [ ("exports", ModuleHeader.Exports) , ("single", ModuleHeader.Single) , ("inline", ModuleHeader.Inline) , ("always", ModuleHeader.Always) ] openBracket = [ ("same_line", ModuleHeader.SameLine) , ("next_line", ModuleHeader.NextLine) ] -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step parseSimpleAlign c o = SimpleAlign.step <$> pure (configColumns c) <*> (SimpleAlign.Config <$> parseAlign "cases" SimpleAlign.cCases <*> parseAlign "top_level_patterns" SimpleAlign.cTopLevelPatterns <*> parseAlign "records" SimpleAlign.cRecords <*> parseAlign "multi_way_if" SimpleAlign.cMultiWayIf) where parseAlign key f = (o A..:? key >>= parseEnum aligns (f SimpleAlign.defaultConfig)) <|> (boolToAlign <$> o A..: key) aligns = [ ("always", SimpleAlign.Always) , ("adjacent", SimpleAlign.Adjacent) , ("never", SimpleAlign.Never) ] boolToAlign True = SimpleAlign.Always boolToAlign False = SimpleAlign.Never -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step parseRecords c o = Data.step <$> (Data.Config <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) <*> (o A..: "field_comment") <*> (o A..: "deriving") <*> (o A..:? "break_enums" A..!= False) <*> (o A..:? "break_single_constructors" A..!= True) <*> (o A..: "via" >>= parseIndent) <*> (o A..:? "curried_context" A..!= False) <*> (o A..:? "sort_deriving" A..!= True) <*> pure configMaxColumns) where configMaxColumns = maybe Data.NoMaxColumns Data.MaxColumns (configColumns c) parseIndent :: A.Value -> A.Parser Data.Indent parseIndent = \case A.String "same_line" -> return Data.SameLine A.String t | "indent " `T.isPrefixOf` t -> case readMaybe (T.unpack $ T.drop 7 t) of Just n -> return $ Data.Indent n Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t) A.String t -> fail $ "can't parse indent setting: " <> T.unpack t _ -> fail "Expected string for indent value" -------------------------------------------------------------------------------- parseSquash :: Config -> A.Object -> A.Parser Step parseSquash _ _ = return Squash.step -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step parseImports config o = fmap (Imports.step columns) $ Imports.Options <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign)) <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) -- Note that padding has to be at least 1. Default is 4. <*> (o A..:? "list_padding" >>= maybe (pure $ def Imports.listPadding) parseListPadding) <*> o A..:? "separate_lists" A..!= def Imports.separateLists <*> o A..:? "space_surround" A..!= def Imports.spaceSurround <*> o A..:? "post_qualify" A..!= def Imports.postQualified <*> o A..:? "group_imports" A..!= def Imports.groupImports <*> o A..:? "group_rules" A..!= def Imports.groupRules where def f = f Imports.defaultOptions columns = configColumns config aligns = [ ("global", Imports.Global) , ("file", Imports.File) , ("group", Imports.Group) , ("none", Imports.None) ] listAligns = [ ("new_line", Imports.NewLine) , ("with_module_name", Imports.WithModuleName) , ("with_alias", Imports.WithAlias) , ("after_alias", Imports.AfterAlias) , ("repeat", Imports.Repeat) ] longListAligns = [ ("inline", Imports.Inline) , ("new_line", Imports.InlineWithBreak) , ("new_line_multiline", Imports.InlineToMultiline) , ("multiline", Imports.Multiline) ] emptyListAligns = [ ("inherit", Imports.Inherit) , ("right_after", Imports.RightAfter) ] parseListPadding = \case A.String "module_name" -> pure Imports.LPModuleName A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) v -> A.typeMismatch "'module_name' or >=1 number" v -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step <$> pure (configColumns config) <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) <*> o A..:? "align" A..!= True <*> o A..:? "remove_redundant" A..!= True <*> mkLanguage o where styles = [ ("vertical", LanguagePragmas.Vertical) , ("compact", LanguagePragmas.Compact) , ("compact_line", LanguagePragmas.CompactLine) , ("vertical_compact", LanguagePragmas.VerticalCompact) ] -------------------------------------------------------------------------------- -- | Utilities for validating language prefixes mkLanguage :: A.Object -> A.Parser String mkLanguage o = do lang <- o A..:? "language_prefix" maybe (pure "LANGUAGE") validate lang where validate :: String -> A.Parser String validate s | fmap toLower s == "language" = pure s | otherwise = fail "please provide a valid language prefix" -------------------------------------------------------------------------------- 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 <*> mkLanguage o stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Config/0000755000000000000000000000000007346545000021765 5ustar0000000000000000stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Config/Cabal.hs0000644000000000000000000001365707346545000023337 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Config.Cabal ( findLanguageExtensions ) where -------------------------------------------------------------------------------- import Control.Monad (unless) import qualified Data.ByteString.Char8 as BS import Data.Foldable (traverse_) import Data.List (nub) import Data.Maybe (maybeToList) import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Parsec as Cabal import qualified Distribution.Parsec as Cabal import qualified Distribution.Simple.Utils as Cabal import qualified Distribution.Utils.Path as Cabal import qualified Distribution.Verbosity as Cabal import GHC.Data.Maybe (mapMaybe) import qualified Language.Haskell.Extension as Language import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Verbose import System.Directory (doesFileExist, getCurrentDirectory) -------------------------------------------------------------------------------- findLanguageExtensions :: Verbose -> ConfigSearchStrategy -> IO [(Language.KnownExtension, Bool)] findLanguageExtensions verbose configSearchStrategy = findCabalFile verbose configSearchStrategy >>= maybe (pure []) (readDefaultLanguageExtensions verbose) -------------------------------------------------------------------------------- -- | Find the closest .cabal file, possibly going up the directory structure. findCabalFile :: Verbose -> ConfigSearchStrategy -> IO (Maybe FilePath) findCabalFile verbose configSearchStrategy = case configSearchStrategy of -- If the invocation pointed us to a specific config file, it doesn't make -- much sense to search for cabal files manually (the config file could be -- somewhere like /etc, not necessarily a Haskell project). UseConfig _ -> pure Nothing SearchFromDirectory path -> go [] $ ancestors path SearchFromCurrentDirectory -> getCurrentDirectory >>= go [] . ancestors where go :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) go searched [] = do verbose $ ".cabal file not found, directories searched: " <> show searched verbose $ "Stylish Haskell will work basing on LANGUAGE pragmas in source files." return Nothing go searched (p : ps) = do #if MIN_VERSION_Cabal(3,14,0) let projectRoot = Just $ Cabal.makeSymbolicPath p potentialCabalFile <- Cabal.findPackageDesc projectRoot #else potentialCabalFile <- Cabal.findPackageDesc p #endif case potentialCabalFile of Right cabalFile -> pure $ Just $ #if MIN_VERSION_Cabal(3,14,0) Cabal.interpretSymbolicPath projectRoot cabalFile #else cabalFile #endif _ -> go (p : searched) ps -------------------------------------------------------------------------------- -- | Extract @default-extensions@ fields from a @.cabal@ file readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [(Language.KnownExtension, Bool)] readDefaultLanguageExtensions verbose cabalFile = do verbose $ "Parsing " <> cabalFile <> "..." packageDescription <- readGenericPackageDescription Cabal.silent cabalFile let library :: [Cabal.Library] library = maybeToList $ fst . Cabal.ignoreConditions <$> Cabal.condLibrary packageDescription subLibraries :: [Cabal.Library] subLibraries = fst . Cabal.ignoreConditions . snd <$> Cabal.condSubLibraries packageDescription executables :: [Cabal.Executable] executables = fst . Cabal.ignoreConditions . snd <$> Cabal.condExecutables packageDescription testSuites :: [Cabal.TestSuite] testSuites = fst . Cabal.ignoreConditions . snd <$> Cabal.condTestSuites packageDescription benchmarks :: [Cabal.Benchmark] benchmarks = fst . Cabal.ignoreConditions . snd <$> Cabal.condBenchmarks packageDescription gatherBuildInfos :: [Cabal.BuildInfo] gatherBuildInfos = map Cabal.libBuildInfo library <> map Cabal.libBuildInfo subLibraries <> map Cabal.buildInfo executables <> map Cabal.testBuildInfo testSuites <> map Cabal.benchmarkBuildInfo benchmarks defaultExtensions :: [(Language.KnownExtension, Bool)] defaultExtensions = mapMaybe toPair $ concatMap Cabal.defaultExtensions gatherBuildInfos where toPair (Language.EnableExtension x) = Just (x, True) toPair (Language.DisableExtension x) = Just (x, False) toPair _ = Nothing verbose $ "Gathered default-extensions: " <> show defaultExtensions pure $ nub defaultExtensions readGenericPackageDescription :: Cabal.Verbosity -> FilePath -> IO Cabal.GenericPackageDescription readGenericPackageDescription = readAndParseFile Cabal.parseGenericPackageDescription where readAndParseFile parser verbosity fpath = do exists <- doesFileExist fpath unless exists $ Cabal.die' verbosity $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." bs <- BS.readFile fpath parseString parser verbosity fpath bs parseString parser verbosity name bs = do let (warnings, result) = Cabal.runParseResult (parser bs) traverse_ (Cabal.warn verbosity . Cabal.showPWarning name) warnings case result of Right x -> return x Left (_, errors) -> do traverse_ (Cabal.warn verbosity . Cabal.showPError name) errors Cabal.die' verbosity $ "Failed parsing \"" ++ name ++ "\"." stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Config/Internal.hs0000644000000000000000000000234107346545000024075 0ustar0000000000000000-------------------------------------------------------------------------------- module Language.Haskell.Stylish.Config.Internal ( ConfigSearchStrategy (..) , ancestors ) where -------------------------------------------------------------------------------- import Data.List (inits) import System.FilePath (joinPath, splitPath) -------------------------------------------------------------------------------- -- All ancestors of a dir (including that dir) ancestors :: FilePath -> [FilePath] ancestors = map joinPath . reverse . dropWhile null . inits . splitPath -------------------------------------------------------------------------------- data ConfigSearchStrategy = -- | Don't try to search, just use given config file UseConfig FilePath | -- | Search for @.stylish-haskell.yaml@ starting from given directory. -- If not found, try all ancestor directories, @$XDG_CONFIG\/stylish-haskell\/config.yaml@ and @$HOME\/.stylish-haskell.yaml@ in order. -- If no config is found, default built-in config will be used. SearchFromDirectory FilePath | -- | Like SearchFromDirectory, but using current working directory as a starting point SearchFromCurrentDirectory stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Editor.hs0000644000000000000000000001547207346545000022353 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- -- | 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 ( module Language.Haskell.Stylish.Block , Edits , apply , replace , replaceRealSrcSpan , changeLine , changeLines , insertLines ) where -------------------------------------------------------------------------------- import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block -------------------------------------------------------------------------------- data Change -- | Insert some lines. = CInsert [String] -- | Replace the block of N lines by the given lines. | CBlock Int ([String] -> [String]) -- | Replace (startCol, endCol) by the given string on this line. | CLine Int Int String -------------------------------------------------------------------------------- -- | Due to the function in CBlock we cannot write a lawful Ord instance, but -- this lets us merge-sort changes. beforeChange :: Change -> Change -> Bool beforeChange (CInsert _) _ = True beforeChange _ (CInsert _) = False beforeChange (CBlock _ _) _ = True beforeChange _ (CBlock _ _) = False beforeChange (CLine x _ _) (CLine y _ _) = x <= y -------------------------------------------------------------------------------- prettyChange :: Int -> Change -> String prettyChange l (CInsert ls) = show l ++ " insert " ++ show (length ls) ++ " lines" prettyChange l (CBlock n _) = show l ++ "-" ++ show (l + n) ++ " replace lines" prettyChange l (CLine start end x) = show l ++ ":" ++ show start ++ "-" ++ show end ++ " replace by " ++ show x -------------------------------------------------------------------------------- -- | Merge in order mergeChanges :: [Change] -> [Change] -> [Change] mergeChanges = go where go [] ys = ys go xs [] = xs go (x : xs) (y : ys) = if x `beforeChange` y then x : go xs (y : ys) else y : go (x : xs) ys -------------------------------------------------------------------------------- -- Stores sorted spans to change per line. newtype Edits = Edits {unEdits :: M.Map Int [Change]} -------------------------------------------------------------------------------- instance Show Edits where show edits = unlines $ do (line, changes) <- M.toAscList $ unEdits edits prettyChange line <$> changes -------------------------------------------------------------------------------- instance Semigroup Edits where Edits l <> Edits r = Edits $ M.unionWith mergeChanges l r -------------------------------------------------------------------------------- instance Monoid Edits where mempty = Edits mempty -------------------------------------------------------------------------------- replaceRealSrcSpan :: GHC.RealSrcSpan -> String -> Edits replaceRealSrcSpan rss repl | GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = mempty | otherwise = replace (GHC.srcSpanStartLine rss) (GHC.srcSpanStartCol rss) (GHC.srcSpanEndCol rss) repl -------------------------------------------------------------------------------- replace :: Int -> Int -> Int -> String -> Edits replace line startCol endCol repl | startCol > endCol = mempty | otherwise = Edits $ M.singleton line [CLine startCol endCol repl] -------------------------------------------------------------------------------- changeLine :: Int -> (String -> [String]) -> Edits changeLine start f = changeLines (Block start start) $ \ls -> case ls of l : _ -> f l _ -> f "" -------------------------------------------------------------------------------- changeLines :: Block String -> ([String] -> [String]) -> Edits changeLines (Block start end) f = Edits $ M.singleton start [CBlock (end - start + 1) f] -------------------------------------------------------------------------------- insertLines :: Int -> [String] -> Edits insertLines line ls = Edits $ M.singleton line [CInsert ls] -------------------------------------------------------------------------------- data Conflict = Conflict Int Change Int Change -------------------------------------------------------------------------------- prettyConflict :: Conflict -> String prettyConflict (Conflict l1 c1 l2 c2) = unlines [ "Conflict between edits:" , "- " ++ prettyChange l1 c1 , "- " ++ prettyChange l2 c2 ] -------------------------------------------------------------------------------- conflicts :: Edits -> [Conflict] conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges where checkChanges _ [] = [] checkChanges i (CInsert _ : cs) = checkChanges i cs checkChanges i (c1@(CBlock _ _) : c2 : _) = [Conflict i c1 i c2] checkChanges i [c1@(CBlock n _)] = do i' <- [i + 1 .. i + n - 1] case M.lookup i' edits of Just (c2 : _) -> [Conflict i c1 i' c2] _ -> [] checkChanges i (c1@(CLine xstart xend _) : c2@(CLine ystart _ _) : cs) | xstart == ystart = [Conflict i c1 i c2] | xend > ystart = [Conflict i c1 i c2] | otherwise = checkChanges i (c2 : cs) checkChanges _ (CLine _ _ _ : _) = [] -------------------------------------------------------------------------------- apply :: Edits -> [String] -> [String] apply (Edits edits) = case conflicts (Edits edits) of c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c _ -> go 1 (editsFor 1) where editsFor i = fromMaybe [] $ M.lookup i edits go _ _ [] = [] go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls go i (CInsert ls' : cs) ls = ls' ++ go i cs ls go i (CBlock n f : _cs) ls = let (domain, ls') = splitAt n ls in f domain ++ go (i + n) (editsFor $ i + n) ls' go i (CLine xstart xend x : cs) (l : ls) = let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in go i (adjust xstart xend x <$> cs) (l' : ls) adjust _ _ _ (CInsert xs) = CInsert xs adjust _ _ _ (CBlock n f) = CBlock n f adjust xstart xend x (CLine ystart yend y) | ystart >= xend = let offset = length x - (xend - xstart) in CLine (ystart + offset) (yend + offset) y | otherwise = CLine ystart yend y stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/GHC.hs0000644000000000000000000000765407346545000021531 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-missing-fields #-} -- | Utility functions for working with the GHC AST module Language.Haskell.Stylish.GHC ( dropAfterLocated , dropBeforeLocated , dropBeforeAndAfter -- * Unsafe getters , unsafeGetRealSrcSpan , getEndLineUnsafe , getStartLineUnsafe -- * Standard settings , baseDynFlags -- * Outputable operators , showOutputable -- * Deconstruction , getConDecls , epAnnComments , deepAnnComments ) where -------------------------------------------------------------------------------- import Data.Generics (Data, Typeable, everything, mkQ) import Data.List (sortOn) import qualified GHC.Driver.Ppr as GHC (showPpr) import GHC.Driver.Session (defaultDynFlags) import qualified GHC.Driver.Session as GHC import qualified GHC.Hs as GHC import GHC.Types.SrcLoc (GenLocated (..), Located, RealLocated, RealSrcSpan, SrcSpan (..), srcSpanEndLine, srcSpanStartLine) import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx unsafeGetRealSrcSpan :: Located a -> RealSrcSpan unsafeGetRealSrcSpan = \case (L (RealSrcSpan s _) _) -> s _ -> error "could not get source code location" getStartLineUnsafe :: Located a -> Int getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan getEndLineUnsafe :: Located a -> Int getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropAfterLocated loc xs = case loc of Just (L (RealSrcSpan rloc _) _) -> filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs _ -> xs dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropBeforeLocated loc xs = case loc of Just (L (RealSrcSpan rloc _) _) -> filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs _ -> xs dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b] dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc) baseDynFlags :: GHC.DynFlags baseDynFlags = defaultDynFlags GHCEx.fakeSettings getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs] getConDecls d@GHC.HsDataDefn {} = case GHC.dd_cons d of GHC.NewTypeCon con -> [con] GHC.DataTypeCons _ cons -> cons showOutputable :: GHC.Outputable a => a -> String showOutputable = GHC.showPpr baseDynFlags epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment] epAnnComments GHC.EpAnn {..} = priorAndFollowing comments deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment] deepAnnComments = everything (++) (mkQ [] priorAndFollowing) priorAndFollowing :: GHC.EpAnnComments -> [GHC.LEpaComment] priorAndFollowing = sortOn (GHC.epaLocationRealSrcSpan . GHC.getLoc) . \case GHC.EpaComments {..} -> priorComments GHC.EpaCommentsBalanced {..} -> priorComments ++ followingComments stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Module.hs0000644000000000000000000001303407346545000022342 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} module Language.Haskell.Stylish.Module ( -- * Data types Module , Comments (..) , Lines -- * Getters , moduleImportGroups , queryModule , groupByLine -- * Imports , canMergeImport , mergeModuleImport , importModuleName -- * Pragmas , moduleLanguagePragmas ) where -------------------------------------------------------------------------------- import Data.Char (toLower) import Data.Function (on) import Data.Generics (Typeable, everything, mkQ) import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, mapMaybe) import GHC.Hs (ImportDecl (..), ImportDeclQualifiedStyle (..)) import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import qualified GHC.Types.PkgQual as GHC import GHC.Types.SrcLoc (GenLocated (..), RealSrcSpan (..), unLoc) import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC -------------------------------------------------------------------------------- type Lines = [String] deriving instance Eq GHC.RawPkgQual -------------------------------------------------------------------------------- -- | Concrete module type type Module = GHC.Located (GHC.HsModule GHC.GhcPs) importModuleName :: ImportDecl GhcPs -> String importModuleName = GHC.moduleNameString . GHC.unLoc . GHC.ideclName -- | Returns true if the two import declarations can be merged canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool canMergeImport i0 i1 = and $ fmap (\f -> f i0 i1) [ (==) `on` unLoc . ideclName , (==) `on` ideclPkgQual , (==) `on` ideclSource , hasMergableQualified `on` ideclQualified , (==) `on` fmap unLoc . ideclAs , (==) `on` fmap fst . ideclImportList -- same 'hiding' flags ] where hasMergableQualified QualifiedPre QualifiedPost = True hasMergableQualified QualifiedPost QualifiedPre = True hasMergableQualified q0 q1 = q0 == q1 -- | Comments associated with module newtype Comments = Comments [GHC.RealLocated GHC.EpaComment] -- | Get groups of imports from module moduleImportGroups :: Module -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)] moduleImportGroups = groupByLine (fromMaybe err . GHC.srcSpanToRealSrcSpan . GHC.getLocA) . GHC.hsmodImports . GHC.unLoc where err = error "moduleImportGroups: import without soure span" -- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] groupByLine f = go [] Nothing where go acc _ [] = ne acc go acc mbCurrentLine (x:xs) = let lStart = GHC.srcSpanStartLine (f x) lEnd = GHC.srcSpanEndLine (f x) in case mbCurrentLine of Just lPrevEnd | lPrevEnd + 1 < lStart -> ne acc ++ go [x] (Just lEnd) xs _ -> go (acc ++ [x]) (Just lEnd) xs ne [] = [] ne (x : xs) = [x :| xs] -- | Merge two import declarations, keeping positions from the first -- -- As alluded, this highlights an issue with merging imports. The GHC -- annotation comments aren't attached to any particular AST node. This -- means that right now, we're manually reconstructing the attachment. By -- merging two import declarations, we lose that mapping. -- -- It's not really a big deal if we consider that people don't usually -- comment imports themselves. It _is_ however, systemic and it'd be better -- if we processed comments beforehand and attached them to all AST nodes in -- our own representation. mergeModuleImport :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs mergeModuleImport (L p0 i0) (L _p1 i1) = L p0 $ i0 { ideclImportList = newImportNames } where newImportNames = case (ideclImportList i0, ideclImportList i1) of (Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1)) (Nothing, Nothing) -> Nothing (Just x, Nothing) -> Just x (Nothing, Just x) -> Just x merge xs ys = L.nubBy ((==) `on` showOutputable) (xs ++ ys) -- | Query the module AST using @f@ queryModule :: Typeable a => (a -> [b]) -> Module -> [b] queryModule f = everything (++) (mkQ [] f) moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)] moduleLanguagePragmas = mapMaybe prag . epAnnComments . GHC.hsmodAnn . GHC.hsmodExt . GHC.unLoc where prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String) prag comment = case GHC.ac_tok (GHC.unLoc comment) of GHC.EpaBlockComment str | lang : p1 : ps <- tokenize str, map toLower lang == "language" -> pure (GHC.epaLocationRealSrcSpan (GHC.getLoc comment), p1 :| ps) _ -> Nothing tokenize = words . map (\c -> if c == ',' then ' ' else c) . takeWhile (/= '#') . drop 1 . dropWhile (/= '#') stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Ordering.hs0000644000000000000000000000550407346545000022671 0ustar0000000000000000-------------------------------------------------------------------------------- -- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader', -- and maybe more in the future. This module provides consistent sorting -- utilities. {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Ordering ( compareImports , compareLIE , compareWrappedName , compareOutputableCI ) where -------------------------------------------------------------------------------- import Data.Char (isUpper, toLower) import Data.Function (on) import Data.Ord (comparing) import GHC.Hs import qualified GHC.Hs as GHC import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable (Outputable) import qualified GHC.Utils.Outputable as GHC import Language.Haskell.Stylish.GHC (showOutputable) -------------------------------------------------------------------------------- -- | Compare imports for sorting. Cannot easily be a lawful instance due to -- case insensitivity. compareImports :: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering compareImports i0 i1 = ideclName i0 `compareOutputableCI` ideclName i1 <> showOutputable (ideclPkgQual i0) `compare` showOutputable (ideclPkgQual i1) <> compareOutputableCI i0 i1 -------------------------------------------------------------------------------- -- | NOTE: Can we get rid off this by adding a properly sorting newtype around -- 'RdrName'? compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering compareLIE = comparing $ ieKey . unLoc where -- | The implementation is a bit hacky to get proper sorting for input specs: -- constructors first, followed by functions, and then operators. ieKey :: IE GhcPs -> (Int, String) ieKey = \case IEVar _ n _ -> nameKey n IEThingAbs _ n _ -> nameKey n IEThingAll _ n _ -> nameKey n IEThingWith _ n _ _ _ -> nameKey n IEModuleContents _ n -> nameKey n _ -> (2, "") -------------------------------------------------------------------------------- compareWrappedName :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering compareWrappedName = comparing nameKey -------------------------------------------------------------------------------- nameKey :: Outputable name => name -> (Int, String) nameKey n = case showOutputable n of o@('(' : _) -> (2, o) o@(o0 : _) | isUpper o0 -> (0, o) o -> (1, o) -------------------------------------------------------------------------------- compareOutputableCI :: GHC.Outputable a => a -> a -> Ordering compareOutputableCI = compare `on` (map toLower . showOutputable) stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Parse.hs0000644000000000000000000001300307346545000022163 0ustar0000000000000000-------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse ( parseModule ) where -------------------------------------------------------------------------------- import Data.Char (toLower) import Data.List (foldl', stripPrefix) import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Traversable (for) import qualified GHC.Data.StringBuffer as GHC import qualified GHC.Driver.Config.Parser as GHC import GHC.Driver.Ppr as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as LangExt import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Types.Error as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Error as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- type Extensions = [String] -------------------------------------------------------------------------------- data ParseExtensionResult -- | Actual extension, and whether we want to turn it on or off. = ExtensionOk LangExt.Extension Bool -- | Failed to parse extension. | ExtensionError String -- | Other LANGUAGE things that aren't really extensions, like 'Safe'. | ExtensionIgnore -------------------------------------------------------------------------------- parseExtension :: String -> ParseExtensionResult parseExtension str | Just x <- GHCEx.readExtension str = ExtensionOk x True | 'N' : 'o' : str' <- str = case parseExtension str' of ExtensionOk x onOff -> ExtensionOk x (not onOff) result -> result | map toLower str `elem` ignores = ExtensionIgnore | otherwise = ExtensionError $ "Unknown extension: " ++ show str where ignores = ["unsafe", "trustworthy", "safe"] -------------------------------------------------------------------------------- -- | 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 -------------------------------------------------------------------------------- -- | 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 GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module parseModule externalExts0 fp string = do -- Parse extensions. externalExts1 <- fmap catMaybes . for externalExts0 $ \str -> case parseExtension str of ExtensionError err -> Left err ExtensionIgnore -> pure Nothing ExtensionOk x onOff -> pure $ Just (x, onOff) -- Build first dynflags. let dynFlags0 = foldl' toggleExt baseDynFlags externalExts1 -- Parse options from file let fileOptions = fmap GHC.unLoc $ snd $ GHC.getOptions (GHC.initParserOpts dynFlags0) (GHC.stringToStringBuffer string) (fromMaybe "-" fp) fileExtensions = mapMaybe (\str -> do str' <- stripPrefix "-X" str case parseExtension str' of ExtensionOk x onOff -> Just (x, onOff) _ -> Nothing) fileOptions -- Set further dynflags. let dynFlags1 = foldl' toggleExt dynFlags0 fileExtensions `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Possibly strip CPP. let removeCpp s = if GHC.xopt LangExt.Cpp dynFlags1 then unCpp s else s input = removeCpp $ dropBom string -- Actual parse. case GHCEx.parseModule input dynFlags1 of GHC.POk _ m -> Right m GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 . GHC.pprMessages GHC.NoDiagnosticOpts . snd $ GHC.getPsMessages ps where withFileName x = maybe "" (<> ": ") fp <> x toggleExt dynFlags (ext, onOff) = foldl' toggleExt ((if onOff then GHC.xopt_set else GHC.xopt_unset) dynFlags ext) [(rhs, onOff') | (lhs, onOff', rhs) <- GHC.impliedXFlags, lhs == ext] stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Printer.hs0000644000000000000000000002372507346545000022550 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Printer ( Printer(..) , PrinterConfig(..) , PrinterState(..) -- * Alias , P -- * Functions to use the printer , runPrinter , runPrinter_ -- ** Combinators , comma , dot , getCurrentLine , getCurrentLineLength , newline , parenthesize , prefix , putComment , putMaybeLineComment , putOutputable , putCond , putType , putRdrName , putText , sep , space , spaces , suffix , pad -- ** Advanced combinators , withColumns , modifyCurrentLine , wrapping ) where -------------------------------------------------------------------------------- import Prelude hiding (lines) -------------------------------------------------------------------------------- import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SrcLoc (GenLocated (..)) import qualified GHC.Types.SrcLoc as GHC import GHC.TypeLits (symbolVal) import GHC.Utils.Outputable (Outputable) -------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT (..), asks, local) import Control.Monad.State (MonadState, State, get, gets, modify, put, runState) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module (Lines) -- | Shorthand for 'Printer' monad type P = Printer -- | Printer that keeps state of file newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState) -- | Configuration for printer, currently empty data PrinterConfig = PrinterConfig { columns :: !(Maybe Int) } -- | State of printer data PrinterState = PrinterState { lines :: !Lines , linePos :: !Int , currentLine :: !String } -- | Run printer to get printed lines out of module as well as return value of monad runPrinter :: PrinterConfig -> Printer a -> (a, Lines) runPrinter cfg (Printer printer) = let (a, PrinterState parsedLines _ startedLine) = runReaderT printer cfg `runState` PrinterState [] 0 "" in (a, parsedLines <> if startedLine == [] then [] else [startedLine]) -- | Run printer to get printed lines only runPrinter_ :: PrinterConfig -> Printer a -> Lines runPrinter_ cfg printer = snd (runPrinter cfg printer) -- | Print text putText :: String -> P () putText txt = do l <- gets currentLine modify \s -> s { currentLine = l <> txt } -- | Check condition post action, and use fallback if false putCond :: (PrinterState -> Bool) -> P b -> P b -> P b putCond p action fallback = do prevState <- get res <- action currState <- get if p currState then pure res else put prevState >> fallback -- | Print an 'Outputable' putOutputable :: Outputable a => a -> P () putOutputable = putText . showOutputable -- | Put all comments that has positions within 'SrcSpan' and separate by -- passed @P ()@ {- putAllSpanComments :: P () -> SrcSpan -> P () putAllSpanComments suff = \case UnhelpfulSpan _ -> pure () RealSrcSpan rspan -> do cmts <- removeComments \(L rloc _) -> srcSpanStartLine rloc >= srcSpanStartLine rspan && srcSpanEndLine rloc <= srcSpanEndLine rspan forM_ cmts (\c -> putComment c >> suff) -} -- | Print any comment putComment :: GHC.EpaComment -> P () putComment epaComment = case GHC.ac_tok epaComment of GHC.EpaDocComment hs -> putText $ show hs GHC.EpaLineComment s -> putText s GHC.EpaDocOptions s -> putText s GHC.EpaBlockComment s -> putText s putMaybeLineComment :: Maybe GHC.EpaComment -> P () putMaybeLineComment = \case Nothing -> pure () Just cmt -> space >> putComment cmt -- | Print a 'RdrName' putRdrName :: GenLocated GHC.SrcSpanAnnN RdrName -> P () putRdrName rdrName = case GHC.unLoc rdrName of Unqual name -> do let (pre, post) = nameAnnAdornment $ GHC.anns $ GHC.getLoc rdrName putText pre putText (showOutputable name) putText post Qual modulePrefix name -> putModuleName modulePrefix >> dot >> putText (showOutputable name) Orig _ name -> putText (showOutputable name) Exact name -> putText (showOutputable name) nameAnnAdornment :: GHC.NameAnn -> (String, String) nameAnnAdornment = \case GHC.NameAnn {GHC.nann_adornment = na} -> fromAdornment na GHC.NameAnnCommas {GHC.nann_adornment = na} -> fromAdornment na GHC.NameAnnBars {GHC.nann_parensh = (o, c)} -> fromAdornment (GHC.NameParensHash o c) GHC.NameAnnOnly {GHC.nann_adornment = na} -> fromAdornment na GHC.NameAnnRArrow {} -> (mempty, mempty) GHC.NameAnnQuote {} -> ("'", mempty) GHC.NameAnnTrailing {} -> (mempty, mempty) where fromAdornment (GHC.NameParens l r) = (symbolVal l, symbolVal r) fromAdornment (GHC.NameBackquotes l r) = (symbolVal l, symbolVal r) fromAdornment (GHC.NameParensHash l r) = (symbolVal l, symbolVal r) fromAdornment (GHC.NameSquare l r) = (symbolVal l, symbolVal r) fromAdornment GHC.NameNoAdornment = (mempty, mempty) -- | Print module name putModuleName :: GHC.ModuleName -> P () putModuleName = putText . GHC.moduleNameString -- | Print type putType :: GHC.LHsType GhcPs -> P () putType ltp = case GHC.unLoc ltp of GHC.HsFunTy _ arrowTp argTp funTp -> do putOutputable argTp space case arrowTp of GHC.HsUnrestrictedArrow {} -> putText "->" GHC.HsLinearArrow {} -> putText "%1 ->" GHC.HsExplicitMult {} -> putOutputable arrowTp space putType funTp GHC.HsAppTy _ t1 t2 -> putType t1 >> space >> putType t2 GHC.HsExplicitListTy _ _ xs -> do putText "'[" sep (comma >> space) (fmap putType xs) putText "]" GHC.HsExplicitTupleTy _ _ xs -> do putText "'(" sep (comma >> space) (fmap putType xs) putText ")" GHC.HsOpTy _ _ lhs op rhs -> do putType lhs space putRdrName op space putType rhs GHC.HsTyVar _ flag rdrName -> do case flag of GHC.IsPromoted -> putText "'" GHC.NotPromoted -> pure () putRdrName rdrName GHC.HsTyLit _ tp -> putOutputable tp GHC.HsParTy _ tp -> do putText "(" putType tp putText ")" GHC.HsTupleTy _ _ xs -> do putText "(" sep (comma >> space) (fmap putType xs) putText ")" GHC.HsForAllTy {} -> putOutputable ltp GHC.HsQualTy {} -> putOutputable ltp GHC.HsAppKindTy _ _ _ -> putOutputable ltp GHC.HsListTy _ _ -> putOutputable ltp GHC.HsSumTy _ _ -> putOutputable ltp GHC.HsIParamTy _ _ _ -> putOutputable ltp GHC.HsKindSig _ _ _ -> putOutputable ltp GHC.HsStarTy _ _ -> putOutputable ltp GHC.HsSpliceTy _ _ -> putOutputable ltp GHC.HsDocTy _ _ _ -> putOutputable ltp GHC.HsBangTy _ _ _ -> putOutputable ltp GHC.HsRecTy _ _ -> putOutputable ltp GHC.HsWildCardTy _ -> putOutputable ltp GHC.XHsType _ -> putOutputable ltp -- | Print a newline newline :: P () newline = do l <- gets currentLine modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] } -- | Print a space space :: P () space = putText " " -- | Print a number of spaces spaces :: Int -> P () spaces i = replicateM_ i space -- | Print a dot dot :: P () dot = putText "." -- | Print a comma comma :: P () comma = putText "," -- | Add parens around a printed action parenthesize :: P a -> P a parenthesize action = putText "(" *> action <* putText ")" -- | Add separator between each element of the given printers sep :: P a -> [P a] -> P () sep _ [] = pure () sep s (first : rest) = first >> forM_ rest ((>>) s) -- | Prefix a printer with another one prefix :: P a -> P b -> P b prefix pa pb = pa >> pb -- | Suffix a printer with another one suffix :: P a -> P b -> P a suffix pa pb = pb >> pa -- | Indent to a given number of spaces. If the current line already exceeds -- that number in length, nothing happens. pad :: Int -> P () pad n = do len <- length <$> getCurrentLine spaces $ n - len -- | Get current line getCurrentLine :: P String getCurrentLine = gets currentLine -- | Get current line length getCurrentLineLength :: P Int getCurrentLineLength = fmap length getCurrentLine modifyCurrentLine :: (String -> String) -> P () modifyCurrentLine f = do s0 <- get put s0 {currentLine = f $ currentLine s0} wrapping :: P a -- ^ First printer to run -> P a -- ^ Printer to run if first printer violates max columns -> P a -- ^ Result of either the first or the second printer wrapping p1 p2 = do maxCols <- asks columns case maxCols of -- No wrapping Nothing -> p1 Just c -> do s0 <- get x <- p1 s1 <- get if length (currentLine s1) <= c -- No need to wrap then pure x else do put s0 y <- p2 s2 <- get if length (currentLine s1) == length (currentLine s2) -- Wrapping didn't help! then put s1 >> pure x -- Wrapped else pure y withColumns :: Maybe Int -> P a -> P a withColumns c = local $ \pc -> pc {columns = c} stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step.hs0000644000000000000000000000117507346545000022033 0ustar0000000000000000-------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step ( Lines , Step (..) , makeStep ) where -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- data Step = Step { stepName :: String , stepFilter :: Lines -> Module -> Lines } -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step makeStep = Step stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/0000755000000000000000000000000007346545000021473 5ustar0000000000000000stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/Data.hs0000644000000000000000000004743107346545000022711 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Data ( Config(..) , defaultConfig , Indent(..) , MaxColumns(..) , step ) where -------------------------------------------------------------------------------- import Control.Monad (forM_, unless, when) import Data.Foldable (toList) import Data.List (sortBy) import Data.Maybe (listToMaybe, maybeToList) import qualified GHC.Hs as GHC import qualified GHC.Types.Fixity as GHC import qualified GHC.Types.Name.Reader as GHC import qualified GHC.Types.SrcLoc as GHC import Prelude hiding (init) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Comments import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Indent = SameLine | Indent !Int deriving (Show, Eq) data MaxColumns = MaxColumns !Int | NoMaxColumns deriving (Show, Eq) data Config = Config { cEquals :: !Indent -- ^ Indent between type constructor and @=@ sign (measured from column 0) , cFirstField :: !Indent -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name) , cFieldComment :: !Int -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@) , cDeriving :: !Int -- ^ Indent before @deriving@ lines (measured from column 0) , cBreakEnums :: !Bool -- ^ Break enums by newlines and follow the above rules , cBreakSingleConstructors :: !Bool -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@ , cVia :: !Indent -- ^ Indentation between @via@ clause and start of deriving column start , cCurriedContext :: !Bool -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ , cSortDeriving :: !Bool -- ^ If true, will sort type classes in a @deriving@ list. , cMaxColumns :: !MaxColumns } deriving (Show) -- | TODO: pass in MaxColumns? defaultConfig :: Config defaultConfig = Config { cEquals = Indent 4 , cFirstField = Indent 4 , cFieldComment = 2 , cDeriving = 4 , cBreakEnums = True , cBreakSingleConstructors = False , cVia = Indent 4 , cSortDeriving = True , cMaxColumns = NoMaxColumns , cCurriedContext = False } step :: Config -> Step step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) ls where changes :: Module -> Editor.Edits changes = foldMap (formatDataDecl cfg) . dataDecls getComments :: GHC.RealSrcSpan -> GHC.SrcSpanAnnA -> [GHC.LEpaComment] getComments declSpan declAnnos= filter isAfterStart $ epAnnComments declAnnos where -- workaround to make sure we don't reprint a haddock -- comment before a data declaration after a data -- declaration isAfterStart :: GHC.LEpaComment -> Bool isAfterStart (GHC.L (GHC.EpaSpan (GHC.RealSrcSpan commentSpan _)) _) = GHC.srcSpanStartLine commentSpan >= GHC.srcSpanStartLine declSpan isAfterStart (GHC.L (GHC.EpaDelta (GHC.RealSrcSpan commentSpan _) _ _) _) = GHC.srcSpanStartLine commentSpan >= GHC.srcSpanStartLine declSpan isAfterStart _ = False dataDecls :: Module -> [DataDecl] dataDecls m = do ldecl <- GHC.hsmodDecls $ GHC.unLoc m (GHC.L declAnnos (GHC.TyClD _ tycld)) <- pure ldecl declSpan <- maybeToList $ GHC.srcSpanToRealSrcSpan $ GHC.getLocA ldecl case tycld of GHC.DataDecl {..} -> pure $ MkDataDecl { dataComments = getComments declSpan declAnnos , dataLoc = declSpan , dataDeclName = tcdLName , dataTypeVars = tcdTyVars , dataDefn = tcdDataDefn , dataFixity = tcdFixity } _ -> [] data DataDecl = MkDataDecl { dataComments :: [GHC.LEpaComment] , dataLoc :: GHC.RealSrcSpan , dataDeclName :: GHC.LocatedN GHC.RdrName , dataTypeVars :: GHC.LHsQTyVars GHC.GhcPs , dataDefn :: GHC.HsDataDefn GHC.GhcPs , dataFixity :: GHC.LexicalFixity } formatDataDecl :: Config -> DataDecl -> Editor.Edits formatDataDecl cfg@Config{..} decl@MkDataDecl {..} = Editor.changeLines originalDeclBlock (const printedDecl) where originalDeclBlock = Editor.Block (GHC.srcSpanStartLine dataLoc) (GHC.srcSpanEndLine dataLoc) printerConfig = PrinterConfig { columns = case cMaxColumns of NoMaxColumns -> Nothing MaxColumns n -> Just n } printedDecl = runPrinter_ printerConfig $ putDataDecl cfg decl putDataDecl :: Config -> DataDecl -> P () putDataDecl cfg@Config {..} decl = do let defn = dataDefn decl constructorComments = commentGroups (GHC.srcSpanToRealSrcSpan . GHC.getLocA) (getConDecls defn) (dataComments decl) onelineEnum = isEnum decl && not cBreakEnums && all (not . commentGroupHasComments) constructorComments putText $ newOrData decl space putName decl when (isGADT decl) (space >> putText "where") when (hasConstructors decl) do case (cEquals, cFirstField) of (_, Indent x) | isEnum decl && cBreakEnums -> newline >> spaces x (_, _) | not (isNewtype decl) , singleConstructor decl && not cBreakSingleConstructors -> space (Indent x, _) | onelineEnum -> space | otherwise -> newline >> spaces x (SameLine, _) -> space lineLengthAfterEq <- fmap (+2) getCurrentLineLength if | onelineEnum -> putText "=" >> space >> putUnbrokenEnum cfg decl | isNewtype decl -> do putText "=" >> space forM_ (GHC.dd_cons defn) $ putNewtypeConstructor cfg | not . null $ GHC.dd_cons defn -> do forM_ (flagEnds constructorComments) $ \(CommentGroup {..}, firstGroup, lastGroup) -> do forM_ cgPrior $ \lc -> do putComment $ GHC.unLoc lc consIndent lineLengthAfterEq forM_ (flagEnds cgItems) $ \((lcon, mbInlineComment), firstItem, lastItem) -> do unless (isGADT decl) $ do putText $ if firstGroup && firstItem then "=" else "|" space putConstructor cfg lineLengthAfterEq lcon putMaybeLineComment $ GHC.unLoc <$> mbInlineComment unless (lastGroup && lastItem) $ consIndent lineLengthAfterEq forM_ cgFollowing $ \lc -> do consIndent lineLengthAfterEq putComment $ GHC.unLoc lc | otherwise -> pure () let derivingComments = deepAnnComments (GHC.dd_derivs defn) when (hasDeriving decl) do if onelineEnum && null derivingComments then do newline spaces cDeriving else do forM_ derivingComments $ \lc -> do newline spaces cDeriving putComment $ GHC.unLoc lc newline spaces cDeriving sep (newline >> spaces cDeriving) $ map (putDeriving cfg) (GHC.dd_derivs defn) where consIndent eqIndent = newline >> case (cEquals, cFirstField) of (SameLine, SameLine) -> spaces (eqIndent - 2) (SameLine, Indent y) -> spaces (eqIndent + y - 4) (Indent x, Indent _) -> spaces x (Indent x, SameLine) -> spaces x derivingClauseTypes :: GHC.HsDerivingClause GHC.GhcPs -> [GHC.LHsSigType GHC.GhcPs] derivingClauseTypes GHC.HsDerivingClause {..} = case GHC.unLoc deriv_clause_tys of GHC.DctSingle _ t -> [t] GHC.DctMulti _ ts -> ts putDeriving :: Config -> GHC.LHsDerivingClause GHC.GhcPs -> P () putDeriving Config{..} lclause = do let clause@GHC.HsDerivingClause {..} = GHC.unLoc lclause tys = (if cSortDeriving then sortBy compareOutputableCI else id) $ map (GHC.sig_body . GHC.unLoc) $ derivingClauseTypes clause headTy = listToMaybe tys tailTy = drop 1 tys putText "deriving" forM_ deriv_clause_strategy $ \lstrat -> case GHC.unLoc lstrat of GHC.StockStrategy {} -> space >> putText "stock" GHC.AnyclassStrategy {} -> space >> putText "anyclass" GHC.NewtypeStrategy {} -> space >> putText "newtype" GHC.ViaStrategy {} -> pure () putCond withinColumns do space putText "(" sep (comma >> space) (fmap putOutputable tys) putText ")" do newline spaces indentation putText "(" forM_ headTy \t -> space >> putOutputable t forM_ tailTy \t -> do newline spaces indentation comma space putOutputable t newline spaces indentation putText ")" forM_ deriv_clause_strategy $ \lstrat -> case GHC.unLoc lstrat of GHC.ViaStrategy tp -> do case cVia of SameLine -> space Indent x -> newline >> spaces (x + cDeriving) putText "via" space putType $ case tp of GHC.XViaStrategyPs _ ty -> GHC.sig_body $ GHC.unLoc ty _ -> pure () -- putEolComment pos where withinColumns PrinterState{currentLine} = case cMaxColumns of MaxColumns maxCols -> length currentLine <= maxCols NoMaxColumns -> True indentation = cDeriving + case cFirstField of Indent x -> x SameLine -> 0 putUnbrokenEnum :: Config -> DataDecl -> P () putUnbrokenEnum cfg decl = sep (space >> putText "|" >> space) (fmap (putConstructor cfg 0) . getConDecls . dataDefn $ decl) putName :: DataDecl -> P () putName decl@MkDataDecl{..} = if isInfix decl then do forM_ firstTvar (\t -> putOutputable t >> space) putRdrName dataDeclName space forM_ secondTvar putOutputable maybePutKindSig else do putRdrName dataDeclName forM_ (GHC.hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) maybePutKindSig where firstTvar :: Maybe (GHC.LHsTyVarBndr (GHC.HsBndrVis GHC.GhcPs) GHC.GhcPs) firstTvar = listToMaybe $ GHC.hsq_explicit dataTypeVars secondTvar :: Maybe (GHC.LHsTyVarBndr (GHC.HsBndrVis GHC.GhcPs) GHC.GhcPs) secondTvar = listToMaybe . drop 1 $ GHC.hsq_explicit dataTypeVars maybePutKindSig :: Printer () maybePutKindSig = forM_ maybeKindSig (\k -> space >> putText "::" >> space >> putOutputable k) maybeKindSig :: Maybe (GHC.LHsKind GHC.GhcPs) maybeKindSig = GHC.dd_kindSig dataDefn putConstructor :: Config -> Int -> GHC.LConDecl GHC.GhcPs -> P () putConstructor cfg consIndent lcons = case GHC.unLoc lcons of GHC.ConDeclGADT {..} -> do -- Put argument to constructor first: case con_g_args of GHC.PrefixConGADT _ _ -> sep (comma >> space) $ fmap putRdrName $ toList con_names GHC.RecConGADT _ _ -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putConstructor: " , "encountered a GADT with record constructors, not supported yet" ] -- Put type of constructor: space putText "::" space putForAll (case GHC.unLoc con_bndrs of GHC.HsOuterImplicit {} -> False GHC.HsOuterExplicit {} -> True) (case GHC.unLoc con_bndrs of GHC.HsOuterImplicit {} -> [] GHC.HsOuterExplicit {..} -> hso_bndrs) forM_ con_mb_cxt $ putContext cfg case con_g_args of GHC.PrefixConGADT _ scaledTys -> forM_ scaledTys $ \scaledTy -> do putType $ GHC.hsScaledThing scaledTy space >> putText "->" >> space GHC.RecConGADT _ _ -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putConstructor: " , "encountered a GADT with record constructors, not supported yet" ] putType con_res_ty GHC.ConDeclH98 {..} -> do putForAll con_forall con_ex_tvs forM_ con_mb_cxt $ putContext cfg case con_args of GHC.InfixCon arg1 arg2 -> do putType $ GHC.hsScaledThing arg1 space putRdrName con_name space putType $ GHC.hsScaledThing arg2 GHC.PrefixCon _tyargs args -> do putRdrName con_name unless (null args) space sep space (fmap (putOutputable . GHC.hsScaledThing) args) GHC.RecCon largs | _ : _ <- GHC.unLoc largs -> do putRdrName con_name skipToBrace bracePos <- getCurrentLineLength putText "{" let fieldPos = bracePos + 2 space let commented = commentGroups (GHC.srcSpanToRealSrcSpan . GHC.getLocA) (GHC.unLoc largs) (epAnnComments $ GHC.getLoc largs) forM_ (flagEnds commented) $ \(CommentGroup {..}, firstCommentGroup, _) -> do -- Unless everything's configured to be on the same line, put pending -- comments forM_ cgPrior $ \lc -> do pad fieldPos putComment $ GHC.unLoc lc sepDecl bracePos forM_ (flagEnds cgItems) $ \((item, mbInlineComment), firstItem, _) -> do if firstCommentGroup && firstItem then pad fieldPos else do comma space putConDeclField cfg $ GHC.unLoc item case mbInlineComment of Just c -> do sepDecl bracePos >> spaces (cFieldComment cfg) putComment $ GHC.unLoc c _ -> pure () sepDecl bracePos forM_ cgFollowing $ \lc -> do spaces $ cFieldComment cfg putComment $ GHC.unLoc lc sepDecl bracePos -- Print whitespace to closing brace putText "}" GHC.RecCon _ -> do skipToBrace >> putText "{" skipToBrace >> putText "}" where -- Jump to the first brace of the first record of the first constructor. skipToBrace = case (cEquals cfg, cFirstField cfg) of (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y (SameLine, SameLine) -> space (Indent x, Indent y) -> newline >> spaces (x + y + 2) (SameLine, Indent y) -> newline >> spaces (consIndent + y) (Indent _, SameLine) -> space -- Jump to the next declaration. sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of (_, Indent y) | not (cBreakSingleConstructors cfg) -> y (SameLine, SameLine) -> bracePos (Indent x, Indent y) -> x + y + 2 (SameLine, Indent y) -> bracePos + y - 2 (Indent x, SameLine) -> bracePos + x - 2 putNewtypeConstructor :: Config -> GHC.LConDecl GHC.GhcPs -> P () putNewtypeConstructor cfg lcons = case GHC.unLoc lcons of GHC.ConDeclH98{..} -> putRdrName con_name >> case con_args of GHC.PrefixCon _ args -> do unless (null args) space sep space (fmap (putOutputable . GHC.hsScaledThing) args) GHC.RecCon largs | [firstArg] <- GHC.unLoc largs -> do space putText "{" space putConDeclField cfg $ GHC.unLoc firstArg space putText "}" GHC.RecCon {} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "encountered newtype with several arguments" ] GHC.InfixCon {} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "infix newtype constructor" ] GHC.ConDeclGADT{} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "GADT encountered in newtype" ] putForAll :: GHC.OutputableBndrFlag s 'GHC.Parsed => Bool -> [GHC.LHsTyVarBndr s GHC.GhcPs] -> P () putForAll frall ex_tvs = when frall do putText "forall" space sep space $ putOutputable . GHC.unLoc <$> ex_tvs dot space putContext :: Config -> GHC.LHsContext GHC.GhcPs -> P () putContext Config{..} lctx = suffix (space >> putText "=>" >> space) $ case ltys of [lty] | GHC.HsParTy _ tp <- GHC.unLoc lty, cCurriedContext -> putType tp [ctx] -> putType ctx ctxs | cCurriedContext -> sep (space >> putText "=>" >> space) (fmap putType ctxs) ctxs -> parenthesize $ sep (comma >> space) (fmap putType ctxs) where ltys = GHC.unLoc lctx :: [GHC.LHsType GHC.GhcPs] putConDeclField :: Config -> GHC.ConDeclField GHC.GhcPs -> P () putConDeclField cfg GHC.ConDeclField {..} = do sep (comma >> space) (fmap putOutputable cd_fld_names) space putText "::" space putType' cfg cd_fld_type -- | A variant of 'putType' that takes 'cCurriedContext' into account putType' :: Config -> GHC.LHsType GHC.GhcPs -> P () putType' cfg lty = case GHC.unLoc lty of GHC.HsForAllTy GHC.NoExtField tele tp -> do putText "forall" space sep space $ case tele of GHC.HsForAllVis {..} -> putOutputable . GHC.unLoc <$> hsf_vis_bndrs GHC.HsForAllInvis {..} -> putOutputable . GHC.unLoc <$> hsf_invis_bndrs case tele of GHC.HsForAllVis {} -> space >> putText "->" GHC.HsForAllInvis {} -> putText "." space putType' cfg tp GHC.HsQualTy GHC.NoExtField ctx tp -> do putContext cfg ctx putType' cfg tp _ -> putType lty newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" isGADT :: DataDecl -> Bool isGADT = any isGADTCons . GHC.dd_cons . dataDefn where isGADTCons c = case GHC.unLoc c of GHC.ConDeclGADT {} -> True _ -> False isNewtype :: DataDecl -> Bool isNewtype = (== GHC.NewType) . GHC.dataDefnConsNewOrData . GHC.dd_cons . dataDefn isInfix :: DataDecl -> Bool isInfix = (== GHC.Infix) . dataFixity isEnum :: DataDecl -> Bool isEnum = all isUnary . GHC.dd_cons . dataDefn where isUnary c = case GHC.unLoc c of GHC.ConDeclH98 {..} -> case con_args of GHC.PrefixCon tyargs args -> null tyargs && null args _ -> False _ -> False hasConstructors :: DataDecl -> Bool hasConstructors = not . null . GHC.dd_cons . dataDefn singleConstructor :: DataDecl -> Bool singleConstructor = (== 1) . length . GHC.dd_cons . dataDefn hasDeriving :: DataDecl -> Bool hasDeriving = not . null . GHC.dd_derivs . dataDefn stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/Imports.hs0000644000000000000000000006274307346545000023500 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Imports ( Options (..) , defaultOptions , ImportAlign (..) , ListAlign (..) , LongListAlign (..) , EmptyListAlign (..) , ListPadding (..) , GroupRule (..) , step , printImport , parsePattern , unsafeParsePattern ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) import Control.Monad (forM_, void, when) import qualified Data.Aeson as A import Data.Foldable (toList) import Data.Function (on, (&)) import Data.Functor (($>)) import Data.List (groupBy, intercalate, partition, sortBy, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Sequence (Seq ((:|>))) import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T import qualified GHC.Data.FastString as GHC import qualified GHC.Hs as GHC import qualified GHC.Types.Name.Reader as GHC import qualified GHC.Types.PkgQual as GHC import qualified GHC.Types.SourceText as GHC import qualified GHC.Types.SrcLoc as GHC --import qualified GHC.Unit.Module.Name as GHC --import qualified GHC.Unit.Types as GHC import qualified Text.Regex.TDFA as Regex import Text.Regex.TDFA (Regex) import Text.Regex.TDFA.ReadRegex (parseRegex) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Options = Options { importAlign :: ImportAlign , listAlign :: ListAlign , padModuleNames :: Bool , longListAlign :: LongListAlign , emptyListAlign :: EmptyListAlign , listPadding :: ListPadding , separateLists :: Bool , spaceSurround :: Bool , postQualified :: Bool , groupImports :: Bool , groupRules :: [GroupRule] } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options { importAlign = Global , listAlign = AfterAlias , padModuleNames = True , longListAlign = Inline , emptyListAlign = Inherit , listPadding = LPConstant 4 , separateLists = True , spaceSurround = False , postQualified = False , groupImports = False , groupRules = [defaultGroupRule] } where defaultGroupRule = GroupRule { match = unsafeParsePattern ".*" , subGroup = Just $ unsafeParsePattern "^[^.]+" } data ListPadding = LPConstant Int | LPModuleName deriving (Eq, Show) data ImportAlign = Global | File | Group | None deriving (Eq, Show) data ListAlign = NewLine | WithModuleName | WithAlias | AfterAlias | Repeat deriving (Eq, Show) data EmptyListAlign = Inherit | RightAfter deriving (Eq, Show) data LongListAlign = Inline -- inline | InlineWithBreak -- new_line | InlineToMultiline -- new_line_multiline | Multiline -- multiline deriving (Eq, Show) -- | A rule for grouping imports that specifies which module names -- belong in a group and (optionally) how to break them up into -- sub-groups. -- -- See the documentation for the group_rules setting in -- data/stylish-haskell.yaml for more details. data GroupRule = GroupRule { match :: Pattern -- ^ The pattern that determines whether a rule applies to a -- module name. , subGroup :: Maybe Pattern -- ^ An optional pattern for breaking the group up into smaller -- sub-groups. } deriving (Show, Eq) instance A.FromJSON GroupRule where parseJSON = A.withObject "group_rule" parse where parse o = GroupRule <$> (o A..: "match") <*> (o A..:? "sub_group") -- | A compiled regular expression. Provides instances that 'Regex' -- does not have (eg 'Show', 'Eq' and 'FromJSON'). -- -- Construct with 'parsePattern' to maintain the invariant that -- 'string' is the exact regex string used to compile 'regex'. data Pattern = Pattern { regex :: Regex -- ^ The compiled regular expression. , string :: String -- ^ The valid regex string that 'regex' was compiled from. } instance Show Pattern where show = show . string instance Eq Pattern where (==) = (==) `on` string instance A.FromJSON Pattern where parseJSON = A.withText "regex" parse where parse text = case parsePattern $ T.unpack text of Left err -> fail $ "Invalid regex:\n" <> err Right pat -> pure pat -- | Parse a string into a compiled regular expression ('Pattern'). -- -- Returns a human-readable parse error message if the string is not -- valid regex syntax. -- -- >>> parsePattern "^([^.]+)" -- Right "^([^.]+)" -- -- >>> parsePattern "(" -- Left "\"(\" (line 1, column 2):\nunexpected end of input\nexpecting empty () or anchor ^ or $ or an atom" parsePattern :: String -> Either String Pattern parsePattern string = case parseRegex string of Right _ -> Right $ Pattern { string, regex = Regex.makeRegex string } Left err -> Left (show err) -- | Parse a string into a regular expression, raising a runtime -- exception if the string is not valid regex syntax. -- -- >>> unsafeParsePattern "^([^.]+)" -- "^([^.]+)" -- -- >>> unsafeParsePattern "(" -- "*** Exception: "(" (line 1, column 2): -- unexpected end of input -- expecting empty () or anchor ^ or $ or an atom unsafeParsePattern :: String -> Pattern unsafeParsePattern = either error id . parsePattern -------------------------------------------------------------------------------- step :: Maybe Int -> Options -> Step step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines printImports maxCols options ls m = Editor.apply changes ls where groups = moduleImportGroups m moduleStats = foldMap importStats . fmap GHC.unLoc $ concatMap toList groups changes | groupImports options = groupAndFormat maxCols options moduleStats groups | otherwise = foldMap (formatGroup maxCols options moduleStats) groups formatGroup :: Maybe Int -> Options -> ImportStats -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Editor.Edits formatGroup maxCols options moduleStats imports = let newLines = formatImports maxCols options moduleStats imports in Editor.changeLines (importBlock imports) (const newLines) importBlock :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Block String importBlock group = Block (GHC.srcSpanStartLine . src $ NonEmpty.head group) (GHC.srcSpanEndLine . src $ NonEmpty.last group) where src = fromMaybe (error "importBlock: missing location") . GHC.srcSpanToRealSrcSpan . GHC.getLocA formatImports :: Maybe Int -- ^ Max columns. -> Options -- ^ Options. -> ImportStats -- ^ Module stats. -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Lines formatImports maxCols options moduleStats rawGroup = runPrinter_ (PrinterConfig maxCols) do let group :: NonEmpty (GHC.LImportDecl GHC.GhcPs) group = NonEmpty.sortBy (compareImports `on` GHC.unLoc) rawGroup & mergeImports unLocatedGroup = fmap GHC.unLoc $ toList group align' = importAlign options padModuleNames' = padModuleNames options padNames = align' /= None && padModuleNames' stats = case align' of Global -> moduleStats {isAnyQualified = True} File -> moduleStats Group -> foldMap importStats unLocatedGroup None -> mempty forM_ group \imp -> printQualified options padNames stats imp >> newline -------------------------------------------------------------------------------- -- | Reorganize imports into groups based on 'groupPatterns', then -- format each group as specified by the rest of 'Options'. -- -- Note: this will discard blank lines and comments inside the imports -- section. groupAndFormat :: Maybe Int -> Options -> ImportStats -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)] -> Editor.Edits groupAndFormat _ _ _ [] = mempty groupAndFormat maxCols options moduleStats groups = Editor.changeLines block (const regroupedLines) where regroupedLines :: Lines regroupedLines = intercalate [""] $ map (formatImports maxCols options moduleStats) grouped grouped :: [NonEmpty (GHC.LImportDecl GHC.GhcPs)] grouped = groupByRules (groupRules options) imports imports :: [GHC.LImportDecl GHC.GhcPs] imports = concatMap toList groups -- groups is non-empty by the pattern for this case -- imports is non-empty as long as groups is non-empty block = Block (GHC.srcSpanStartLine . src $ head imports) (GHC.srcSpanEndLine . src $ last imports) src = fromMaybe (error "regroupImports: missing location") . GHC.srcSpanToRealSrcSpan . GHC.getLocA -- | Group imports based on a list of patterns. -- -- See the documentation for @group_patterns@ in -- @data/stylish-haskell.yaml@ for details about the patterns and -- grouping logic. groupByRules :: [GroupRule] -- ^ The patterns specifying the groups to build. Order matters: -- earlier patterns take precedence over later ones. -> [GHC.LImportDecl GHC.GhcPs] -- ^ The imports to group. Order does not matter. -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)] groupByRules rules allImports = toList $ go rules allImports Seq.empty where go :: [GroupRule] -> [GHC.LImportDecl GHC.GhcPs] -> Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs)) -> Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs)) go [] [] groups = groups go [] imports groups = groups :|> NonEmpty.fromList imports go (r : rs) imports groups = let (groups', rest) = extract r imports in go rs rest (groups <> groups') extract :: GroupRule -> [GHC.LImportDecl GHC.GhcPs] -> ( Seq (NonEmpty (GHC.LImportDecl GHC.GhcPs)) , [GHC.LImportDecl GHC.GhcPs] ) extract GroupRule { match, subGroup } imports = let (matched, rest) = partition (matches match) imports subgroups = groupBy ((==) `on` firstMatch subGroup) $ sortOn (firstMatch subGroup) matched in -- groupBy never produces empty groups, so this mapMaybe will -- not discard anything from subgroups (Seq.fromList $ mapMaybe NonEmpty.nonEmpty subgroups, rest) matches :: Pattern -> GHC.LImportDecl GHC.GhcPs -> Bool matches Pattern { regex } import_ = Regex.match regex $ moduleName import_ firstMatch :: Maybe Pattern -> GHC.LImportDecl GHC.GhcPs -> String firstMatch (Just Pattern { regex }) import_ = Regex.match regex $ moduleName import_ firstMatch Nothing _ = "" -- constant grouping key, so everything will be grouped together moduleName = importModuleName . GHC.unLoc -------------------------------------------------------------------------------- printQualified :: Options -> Bool -> ImportStats -> GHC.LImportDecl GHC.GhcPs -> P () printQualified Options{..} padNames stats ldecl = do putText "import" >> space case (isSource decl, isAnySource stats) of (True, _) -> putText "{-# SOURCE #-}" >> space (_, True) -> putText " " >> space _ -> pure () when (GHC.ideclSafe decl) (putText "safe" >> space) let module_ = do moduleNamePosition <- length <$> getCurrentLine case GHC.ideclPkgQual decl of GHC.NoRawPkgQual -> pure () GHC.RawPkgQual pkg -> putText (stringLiteral pkg) >> space putText (importModuleName decl) -- Only print spaces if something follows. let somethingFollows = isJust (GHC.ideclAs decl) || isHiding decl || not (null $ GHC.ideclImportList decl) when (padNames && somethingFollows) $ putText $ replicate (isLongestImport stats - importModuleNameLength decl) ' ' pure moduleNamePosition moduleNamePosition <- case (postQualified, isQualified decl, isAnyQualified stats) of (False, True , _ ) -> putText "qualified" *> space *> module_ (False, _ , True) -> putText " " *> space *> module_ (True , True , _ ) -> module_ <* space <* putText "qualified" _ -> module_ beforeAliasPosition <- length <$> getCurrentLine forM_ (GHC.ideclAs decl) $ \lname -> do space >> putText "as" >> space putText . GHC.moduleNameString $ GHC.unLoc lname afterAliasPosition <- length <$> getCurrentLine when (isHiding decl) (space >> putText "hiding") let putOffset = putText $ replicate offset ' ' offset = case listPadding of LPConstant n -> n LPModuleName -> moduleNamePosition pure () case snd <$> GHC.ideclImportList decl of Nothing -> pure () Just limports | null (GHC.unLoc limports) -> case emptyListAlign of RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" Inherit -> case listAlign of NewLine -> do modifyCurrentLine trimRight newline >> putOffset >> putText "()" _ -> space >> putText "()" Just limports -> do let imports = GHC.unLoc limports printedImports = flagEnds $ -- [P ()] (printImport separateLists) . GHC.unLoc <$> prepareImportList imports -- Since we might need to output the import module name several times, we -- need to save it to a variable: wrapPrefix <- case listAlign of AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' ' WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' Repeat -> fmap (++ " (") getCurrentLine WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' NewLine -> pure $ replicate offset ' ' -- Helper let doSpaceSurround = when spaceSurround space -- Try to put everything on one line. let printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do when start $ putText "(" >> doSpaceSurround imp if end then doSpaceSurround >> putText ")" else comma >> space -- Try to put everything one by one, wrapping if that fails. let printAsInlineWrapping wprefix = forM_ printedImports $ \(imp, start, end) -> patchForRepeatHiding $ wrapping (do if start then putText "(" >> doSpaceSurround else space imp if end then doSpaceSurround >> putText ")" else comma) (do case listAlign of -- In 'Repeat' mode, end lines with ')' rather than ','. Repeat | not start -> modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c _ | start && spaceSurround -> -- Only necessary if spaceSurround is enabled. modifyCurrentLine trimRight _ -> pure () newline void wprefix case listAlign of -- '(' already included in repeat Repeat -> pure () -- Print the much needed '(' _ | start -> putText "(" >> doSpaceSurround -- Don't bother aligning if we're not in inline mode. _ | longListAlign /= Inline -> pure () -- 'Inline + AfterAlias' is really where we want to be careful -- with spacing. AfterAlias -> space >> doSpaceSurround WithModuleName -> pure () WithAlias -> pure () NewLine -> pure () imp if end then doSpaceSurround >> putText ")" else comma) -- Put everything on a separate line. 'spaceSurround' can be -- ignored. let printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do when start $ modifyCurrentLine trimRight -- We added some spaces. newline putOffset if start then putText "( " else putText ", " imp when end $ newline >> putOffset >> putText ")" case longListAlign of Multiline -> wrapping (space >> printAsSingleLine) printAsMultiLine Inline | NewLine <- listAlign -> do modifyCurrentLine trimRight newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) Inline -> space >> printAsInlineWrapping (putText wrapPrefix) InlineWithBreak -> wrapping (space >> printAsSingleLine) (do modifyCurrentLine trimRight newline >> putOffset >> printAsInlineWrapping putOffset) InlineToMultiline -> wrapping (space >> printAsSingleLine) (wrapping (do modifyCurrentLine trimRight newline >> putOffset >> printAsSingleLine) printAsMultiLine) where decl = GHC.unLoc ldecl -- We cannot wrap/repeat 'hiding' imports since then we would get multiple -- imports hiding different things. patchForRepeatHiding = case listAlign of Repeat | isHiding decl -> withColumns Nothing _ -> id -------------------------------------------------------------------------------- printImport :: Bool -> GHC.IE GHC.GhcPs -> P () printImport _ (GHC.IEVar _ name _) = do printIeWrappedName name printImport _ (GHC.IEThingAbs _ name _) = do printIeWrappedName name printImport separateLists (GHC.IEThingAll _ name _) = do printIeWrappedName name when separateLists space putText "(..)" printImport _ (GHC.IEModuleContents _ modu) = do putText "module" space putText . GHC.moduleNameString $ GHC.unLoc modu printImport separateLists (GHC.IEThingWith _ name wildcard imps _) = do printIeWrappedName name when separateLists space let ellipsis = case wildcard of GHC.IEWildcard _position -> [putText ".."] GHC.NoIEWildcard -> [] parenthesize $ sep (comma >> space) (ellipsis <> fmap printIeWrappedName imps) printImport _ (GHC.IEGroup _ _ _ ) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" printImport _ (GHC.IEDoc _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" printImport _ (GHC.IEDocNamed _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" -------------------------------------------------------------------------------- printIeWrappedName :: GHC.LIEWrappedName GHC.GhcPs -> P () printIeWrappedName lie = case GHC.unLoc lie of GHC.IEName _ n -> putRdrName n GHC.IEPattern _ n -> putText "pattern" >> space >> putRdrName n GHC.IEType _ n -> putText "type" >> space >> putRdrName n mergeImports :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> NonEmpty (GHC.LImportDecl GHC.GhcPs) mergeImports (x :| []) = x :| [] mergeImports (h :| (t : ts)) | canMergeImport (GHC.unLoc h) (GHC.unLoc t) = mergeImports (mergeModuleImport h t :| ts) | otherwise = h :| mergeImportsTail (t : ts) where mergeImportsTail (x : y : ys) | canMergeImport (GHC.unLoc x) (GHC.unLoc y) = mergeImportsTail ((mergeModuleImport x y) : ys) | otherwise = x : mergeImportsTail (y : ys) mergeImportsTail xs = xs -------------------------------------------------------------------------------- data ImportStats = ImportStats { isLongestImport :: !Int , isAnySource :: !Bool , isAnyQualified :: !Bool , isAnySafe :: !Bool } instance Semigroup ImportStats where l <> r = ImportStats { isLongestImport = isLongestImport l `max` isLongestImport r , isAnySource = isAnySource l || isAnySource r , isAnyQualified = isAnyQualified l || isAnyQualified r , isAnySafe = isAnySafe l || isAnySafe r } instance Monoid ImportStats where mappend = (<>) mempty = ImportStats 0 False False False importStats :: GHC.ImportDecl GHC.GhcPs -> ImportStats importStats i = ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (GHC.ideclSafe i) -- Computes length till module name, includes package name. -- TODO: this should reuse code with the printer importModuleNameLength :: GHC.ImportDecl GHC.GhcPs -> Int importModuleNameLength imp = (case GHC.ideclPkgQual imp of GHC.NoRawPkgQual -> 0 GHC.RawPkgQual sl -> 1 + length (stringLiteral sl)) + (length $ importModuleName imp) -------------------------------------------------------------------------------- stringLiteral :: GHC.StringLiteral -> String stringLiteral sl = case GHC.sl_st sl of GHC.NoSourceText -> GHC.unpackFS $ GHC.sl_fs sl GHC.SourceText s -> GHC.unpackFS $ s -------------------------------------------------------------------------------- isQualified :: GHC.ImportDecl GHC.GhcPs -> Bool isQualified = (/=) GHC.NotQualified . GHC.ideclQualified isHiding :: GHC.ImportDecl GHC.GhcPs -> Bool isHiding d = case GHC.ideclImportList d of Just (GHC.EverythingBut, _) -> True _ -> False isSource :: GHC.ImportDecl GHC.GhcPs -> Bool isSource = (==) GHC.IsBoot . GHC.ideclSource -------------------------------------------------------------------------------- -- | Cleans up an import item list. -- -- * Sorts import items. -- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))` -- * Removes duplicates from import lists. prepareImportList :: [GHC.LIE GHC.GhcPs] -> [GHC.LIE GHC.GhcPs] prepareImportList = sortBy compareLIE . map (fmap prepareInner) . concatMap (toList . snd) . Map.toAscList . mergeByName where mergeByName :: [GHC.LIE GHC.GhcPs] -> Map.Map GHC.RdrName (NonEmpty (GHC.LIE GHC.GhcPs)) mergeByName imports0 = Map.fromListWith -- Note that ideally every NonEmpty will just have a single entry and we -- will be able to merge everything into that entry. Exotic imports can -- mess this up, though. So they end up in the tail of the list. (\(x :| xs) (y :| ys) -> case ieMerge (GHC.unLoc x) (GHC.unLoc y) of Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` Nothing -> x :| (xs ++ y : ys)) [(GHC.ieName $ GHC.unLoc imp, imp :| []) | imp <- imports0] prepareInner :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs prepareInner = \case -- Simplify `A ()` to `A`. GHC.IEThingWith x n GHC.NoIEWildcard [] md -> GHC.IEThingAbs (fst x) n md GHC.IEThingWith x n w ns md -> GHC.IEThingWith x n w (sortBy (compareWrappedName `on` GHC.unLoc) ns) md ie -> ie -- Merge two import items, assuming they have the same name. ieMerge :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs -> Maybe (GHC.IE GHC.GhcPs) ieMerge l@(GHC.IEVar _ _ _) _ = Just l ieMerge _ r@(GHC.IEVar _ _ _) = Just r ieMerge (GHC.IEThingAbs _ _ _) r = Just r ieMerge l (GHC.IEThingAbs _ _ _) = Just l ieMerge l@(GHC.IEThingAll _ _ _) _ = Just l ieMerge _ r@(GHC.IEThingAll _ _ _) = Just r ieMerge (GHC.IEThingWith x0 n0 w0 ns0 me0) (GHC.IEThingWith _ _ w1 ns1 me1) | w0 /= w1 = Nothing | otherwise = Just $ -- TODO: sort the `ns0 ++ ns1`? GHC.IEThingWith x0 n0 w0 (nubOn GHC.lieWrappedName $ ns0 ++ ns1) (me0 <|> me1) ieMerge _ _ = Nothing -------------------------------------------------------------------------------- nubOn :: Ord k => (a -> k) -> [a] -> [a] nubOn f = go Set.empty where go _ [] = [] go acc (x : xs) | y `Set.member` acc = go acc xs | otherwise = x : go (Set.insert y acc) xs where y = f x stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs0000644000000000000000000001702307346545000025070 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) , step -- * Utilities , addLanguagePragma ) where -------------------------------------------------------------------------------- import Data.List.NonEmpty (NonEmpty, fromList, toList) import qualified Data.Set as S -------------------------------------------------------------------------------- import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Style = Vertical | Compact | CompactLine | VerticalCompact deriving (Eq, Show) -------------------------------------------------------------------------------- verticalPragmas :: String -> Int -> Bool -> [String] -> Lines verticalPragmas lg longest align pragmas' = [ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}" | pragma <- pragmas' ] where pad | align = padRight longest | otherwise = id -------------------------------------------------------------------------------- compactPragmas :: String -> Maybe Int -> [String] -> Lines compactPragmas lg columns pragmas' = wrapMaybe columns ("{-# " ++ lg) 13 $ map (++ ",") (init pragmas') ++ [last pragmas' ++ " #-}"] -------------------------------------------------------------------------------- compactLinePragmas :: String -> Maybe Int -> Bool -> [String] -> Lines compactLinePragmas _ _ _ [] = [] compactLinePragmas lg columns align pragmas' = map (wrapLanguage . pad) prags where wrapLanguage ps = "{-# " ++ lg ++ ps ++ " #-}" maxWidth = fmap (\c -> c - 16) columns longest = maximum $ map length prags pad | align = padRight longest | otherwise = id prags = map truncateComma $ wrapMaybe maxWidth "" 1 $ map (++ ",") (init pragmas') ++ [last pragmas'] -------------------------------------------------------------------------------- verticalCompactPragmas :: String -> [String] -> Lines verticalCompactPragmas lg pragmas' = [ "{-# " <> lg , " " <> head pragmas' ] <> [ " , " <> pragma | pragma <- tail pragmas'] <> [ " #-}"] -------------------------------------------------------------------------------- truncateComma :: String -> String truncateComma "" = "" truncateComma xs | last xs == ',' = init xs | otherwise = xs -------------------------------------------------------------------------------- prettyPragmas :: String -> Maybe Int -> Int -> Bool -> Style -> [String] -> Lines prettyPragmas lp _ longest align Vertical = verticalPragmas lp longest align prettyPragmas lp cols _ _ Compact = compactPragmas lp cols prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols align prettyPragmas lp _ _ _ VerticalCompact = verticalCompactPragmas lp -------------------------------------------------------------------------------- -- | 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, NonEmpty String)] -> [(l, [String])] filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList) 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 :: Maybe Int -> Style -> Bool -> Bool -> String -> Step step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' -------------------------------------------------------------------------------- step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines step' columns style align removeRedundant lngPrefix ls m | null languagePragmas = ls | otherwise = Editor.apply changes ls where isRedundant' | removeRedundant = isRedundant m | otherwise = const False languagePragmas = moduleLanguagePragmas m convertFstToBlock :: [(GHC.RealSrcSpan, a)] -> [(Block String, a)] convertFstToBlock = fmap \(rspan, a) -> (Block (GHC.srcSpanStartLine rspan) (GHC.srcSpanEndLine rspan), a) groupAdjacent' = fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList) where turnSndBackToNel (a, bss) = (a, fromList . concat $ bss) longest :: Int longest = maximum $ map length $ toList . snd =<< languagePragmas groups :: [(Block String, NonEmpty String)] groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] changes = mconcat [ Editor.changeLines b (const $ prettyPragmas lngPrefix 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 -> String -> Module -> Editor.Edits addLanguagePragma lg prag modu | prag `elem` present = mempty | otherwise = Editor.insertLines line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"] where pragmas' = moduleLanguagePragmas modu present = concatMap (toList . snd) pragmas' line = if null pragmas' then 1 else firstLocation pragmas' firstLocation :: [(GHC.RealSrcSpan, NonEmpty String)] -> Int firstLocation = minimum . fmap (GHC.srcLocLine . GHC.realSrcSpanStart . fst) -------------------------------------------------------------------------------- -- | Check if a language pragma is redundant. We can't do this for all pragmas, -- but we do a best effort. isRedundant :: Module -> String -> Bool isRedundant m "ViewPatterns" = isRedundantViewPatterns m isRedundant m "BangPatterns" = isRedundantBangPatterns m isRedundant _ _ = False -------------------------------------------------------------------------------- -- | Check if the ViewPatterns language pragma is redundant. isRedundantViewPatterns :: Module -> Bool isRedundantViewPatterns = null . queryModule getViewPat where getViewPat :: GHC.Pat GHC.GhcPs -> [()] getViewPat = \case GHC.ViewPat{} -> [()] _ -> [] -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant. isRedundantBangPatterns :: Module -> Bool isRedundantBangPatterns modul = (null $ queryModule getBangPat modul) && (null $ queryModule getMatchStrict modul) where getBangPat :: GHC.Pat GHC.GhcPs -> [()] getBangPat = \case GHC.BangPat{} -> [()] _ -> [] getMatchStrict :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> [()] getMatchStrict (GHC.Match _ ctx _ _) = case ctx of GHC.FunRhs _ _ GHC.SrcStrict _ -> [()] _ -> [] stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs0000644000000000000000000001756307346545000024401 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.ModuleHeader ( Config (..) , BreakWhere (..) , OpenBracket (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) import Control.Monad (guard, unless, when) import Data.Foldable (forM_) import Data.Maybe (fromMaybe, isJust, listToMaybe) import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Comments import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import Language.Haskell.Stylish.Util (flagEnds) import qualified GHC.Unit.Module.Warnings as GHC data Config = Config { indent :: Int , sort :: Bool , separateLists :: Bool , breakWhere :: BreakWhere , openBracket :: OpenBracket } data OpenBracket = SameLine | NextLine deriving (Eq, Show) data BreakWhere = Exports | Single | Inline | Always deriving (Eq, Show) defaultConfig :: Config defaultConfig = Config { indent = 4 , sort = True , separateLists = True , breakWhere = Exports , openBracket = NextLine } step :: Maybe Int -> Config -> Step step maxCols = makeStep "Module header" . printModuleHeader maxCols printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines printModuleHeader maxCols conf ls lmodul = let modul = GHC.unLoc lmodul name = GHC.unLoc <$> GHC.hsmodName modul deprecMsg = GHC.hsmodDeprecMessage $ GHC.hsmodExt modul startLine = fromMaybe 1 $ moduleLine <|> (fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $ GHC.getLoc lmodul) endLine = fromMaybe 1 $ whereLine <|> (do loc <- GHC.getLocA <$> GHC.hsmodExports modul GHC.srcSpanEndLine <$> GHC.srcSpanToRealSrcSpan loc) keywordLine kw = do GHC.EpAnn {..} <- pure $ GHC.hsmodAnn $ GHC.hsmodExt modul case kw anns of GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) -> Just . GHC.srcSpanEndLine $ s _ -> Nothing moduleLine = keywordLine GHC.am_mod whereLine = keywordLine GHC.am_where commentOnLine l = listToMaybe $ do comment <- epAnnComments $ GHC.hsmodAnn $ GHC.hsmodExt modul guard $ GHC.srcSpanStartLine (GHC.epaLocationRealSrcSpan $ GHC.getLoc comment) == l pure comment moduleComment = moduleLine >>= commentOnLine whereComment = guard (whereLine /= moduleLine) >> whereLine >>= commentOnLine exportGroups = case GHC.hsmodExports modul of Nothing -> Nothing Just lexports -> Just $ doSort $ commentGroups (GHC.srcSpanToRealSrcSpan . GHC.getLocA) (GHC.unLoc lexports) (epAnnComments $ GHC.getLoc lexports) printedModuleHeader = runPrinter_ (PrinterConfig maxCols) (printHeader conf name deprecMsg exportGroups moduleComment whereComment) changes = Editor.changeLines (Editor.Block startLine endLine) (const printedModuleHeader) in Editor.apply changes ls where doSort = if sort conf then fmap (commentGroupSort compareLIE) else id printHeader :: Config -> Maybe GHC.ModuleName -> Maybe (GHC.LocatedP (GHC.WarningTxt GHC.GhcPs)) -> Maybe [CommentGroup (GHC.LIE GHC.GhcPs)] -> Maybe GHC.LEpaComment -- Comment attached to 'module' -> Maybe GHC.LEpaComment -- Comment attached to 'where' -> P () printHeader conf mbName mbDeprec mbExps mbModuleComment mbWhereComment = do forM_ mbName $ \name -> do putText "module" space putText (showOutputable name) forM_ mbDeprec \deprec -> do putText " " putText (showOutputable deprec) case mbExps of Nothing -> do when (isJust mbName) $ case breakWhere conf of Always -> do attachModuleComment newline spaces (indent conf) _ -> space putText "where" Just exports -> case breakWhere conf of Single | [] <- exports -> do printSingleLineExportList conf [] attachModuleComment Single | [egroup] <- exports , not (commentGroupHasComments egroup) , [(export, _)] <- cgItems egroup -> do printSingleLineExportList conf [export] attachModuleComment Inline | [] <- exports -> do printSingleLineExportList conf [] attachModuleComment Inline | [egroup] <- exports, not (commentGroupHasComments egroup) -> do wrapping (printSingleLineExportList conf $ map fst $ cgItems egroup) (do attachOpenBracket attachModuleComment printMultiLineExportList conf exports) _ -> do attachOpenBracket attachModuleComment printMultiLineExportList conf exports putMaybeLineComment $ GHC.unLoc <$> mbWhereComment where attachModuleComment = putMaybeLineComment $ GHC.unLoc <$> mbModuleComment attachOpenBracket | openBracket conf == SameLine = putText " (" | otherwise = pure () printSingleLineExportList :: Config -> [GHC.LIE GHC.GhcPs] -> P () printSingleLineExportList conf exports = do space >> putText "(" printExports exports putText ")" >> space >> putText "where" where printExports :: [GHC.LIE GHC.GhcPs] -> P () printExports = \case [] -> pure () [e] -> putExport conf e (e:es) -> putExport conf e >> comma >> space >> printExports es printMultiLineExportList :: Config -> [CommentGroup (GHC.LIE GHC.GhcPs)] -> P () printMultiLineExportList conf exports = do newline doIndent >> putText firstChar >> unless (null exports) space mapM_ printExport $ flagEnds exports when (null exports) $ newline >> doIndent putText ")" >> space >> putText "where" where printExport (CommentGroup {..}, firstGroup, _lastGroup) = do forM_ (flagEnds cgPrior) $ \(cmt, start, _end) -> do unless (firstGroup && start) $ space >> space putComment $ GHC.unLoc cmt newline >> doIndent forM_ (flagEnds cgItems) $ \((export, mbComment), start, _end) -> do if firstGroup && start then unless (null cgPrior) $ space >> space else comma >> space putExport conf export putMaybeLineComment $ GHC.unLoc <$> mbComment newline >> doIndent firstChar = case openBracket conf of SameLine -> " " NextLine -> "(" doIndent = spaces (indent conf) -- NOTE(jaspervdj): This code is almost the same as the import printing in -- 'Imports' and should be merged. putExport :: Config -> GHC.LIE GHC.GhcPs -> P () putExport conf = Imports.printImport (separateLists conf) . GHC.unLoc stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs0000644000000000000000000001636707346545000024250 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , Align (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- import Data.Either (partitionEithers) import Data.Foldable (toList) import Data.List (foldl', foldl1', sortOn) import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified GHC.Parser.Annotation as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Align import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Config = Config { cCases :: Align , cTopLevelPatterns :: Align , cRecords :: Align , cMultiWayIf :: Align } deriving (Show) data Align = Always | Adjacent | Never deriving (Eq, Show) defaultConfig :: Config defaultConfig = Config { cCases = Always , cTopLevelPatterns = Always , cRecords = Always , cMultiWayIf = Always } groupAlign :: Align -> [Alignable GHC.RealSrcSpan] -> [[Alignable GHC.RealSrcSpan]] groupAlign a xs = case a of Never -> [] Adjacent -> byLine . sortOn (GHC.srcSpanStartLine . aLeft) $ xs Always -> [xs] where byLine = map toList . groupByLine aLeft -------------------------------------------------------------------------------- type Record = [GHC.LocatedA (Hs.ConDeclField Hs.GhcPs)] -------------------------------------------------------------------------------- records :: Module -> [Record] records modu = do let decls = map GHC.unLoc (Hs.hsmodDecls (GHC.unLoc modu)) tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] dataDefns = map Hs.tcdDataDefn dataDecls d@Hs.ConDeclH98 {} <- GHC.unLoc <$> concatMap getConDecls dataDefns case Hs.con_args d of Hs.RecCon rec -> [GHC.unLoc rec] _ -> [] -------------------------------------------------------------------------------- recordToAlignable :: Config -> Record -> [[Alignable GHC.RealSrcSpan]] recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- fieldDeclToAlignable :: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan) fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA $ last names tyPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA ty Just $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = tyPos , aRightLead = length ":: " } -------------------------------------------------------------------------------- matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [[Alignable GHC.RealSrcSpan]] matchGroupToAlignable conf mg = cases' ++ patterns' where alts = Hs.mg_alts mg (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (GHC.unLoc alts) cases' = groupAlign (cCases conf) cases patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- matchToAlignable :: GHC.LocatedA (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Either (Alignable GHC.RealSrcSpan) (Alignable GHC.RealSrcSpan)) matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt (GHC.L _ pats@(_ : _)) grhss)) = do let patsLocs = map GHC.getLocA pats pat = last patsLocs guards = getGuards m guardsLocs = map GHC.getLocA guards left = foldl' GHC.combineSrcSpans pat guardsLocs body <- rhsBody grhss matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc leftPos <- GHC.srcSpanToRealSrcSpan left rightPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body Just . Left $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = rightPos , aRightLead = length "-> " } matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _ _) (GHC.L _ pats@(_ : _)) grhss)) = do body <- unguardedRhsBody grhss let patsLocs = map GHC.getLocA pats nameLoc = GHC.getLocA name left = last (nameLoc : patsLocs) bodyLoc = GHC.getLocA body matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc leftPos <- GHC.srcSpanToRealSrcSpan left bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc Just . Right $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "= " } matchToAlignable (GHC.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable :: Config -> Hs.LHsExpr Hs.GhcPs -> [[Alignable GHC.RealSrcSpan]] multiWayIfToAlignable conf (GHC.L _ (Hs.HsMultiIf _ grhss)) = groupAlign (cMultiWayIf conf) as where as = fromMaybe [] $ traverse grhsToAlignable grhss multiWayIfToAlignable _conf _ = [] -------------------------------------------------------------------------------- grhsToAlignable :: GHC.GenLocated (GHC.EpAnnCO) (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable GHC.RealSrcSpan) grhsToAlignable (GHC.L (GHC.EpAnn (GHC.EpaSpan grhsloc) _ _ ) (Hs.GRHS _ guards@(_ : _) body)) = do let guardsLocs = map GHC.getLocA guards bodyLoc = GHC.getLocA $ body left = foldl1' GHC.combineSrcSpans guardsLocs matchPos <- GHC.srcSpanToRealSrcSpan grhsloc leftPos <- GHC.srcSpanToRealSrcSpan left bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc Just $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "-> " } grhsToAlignable (GHC.L _ _) = Nothing -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step step maxColumns config = makeStep "Cases" $ \ls module' -> let changes :: (Module -> [a]) -> (a -> [[Alignable GHC.RealSrcSpan]]) -> Editor.Edits changes search toAlign = mconcat $ do item <- search module' pure $ foldMap (align maxColumns) (toAlign item) configured :: Editor.Edits configured = changes records (recordToAlignable config) <> changes everything (matchGroupToAlignable config) <> changes everything (multiWayIfToAlignable config) in Editor.apply configured ls stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/Squash.hs0000644000000000000000000000675307346545000023306 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.Squash ( step ) where -------------------------------------------------------------------------------- import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -- | Removes anything between two RealSrcSpans, providing they are on the same -- line. squash :: GHC.RealSrcSpan -> GHC.RealSrcSpan -> Editor.Edits squash l r | GHC.srcSpanEndLine l /= GHC.srcSpanStartLine r = mempty | GHC.srcSpanEndCol l >= GHC.srcSpanStartCol r = mempty | otherwise = Editor.replace (GHC.srcSpanEndLine l) (GHC.srcSpanEndCol l) (GHC.srcSpanStartCol r) " " -------------------------------------------------------------------------------- squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits squashFieldDecl (GHC.ConDeclField ext names@(_ : _) type' _) | Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last names , Just sep <- fieldDeclSeparator ext , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA type' = squash left sep <> squash sep right squashFieldDecl _ = mempty -------------------------------------------------------------------------------- fieldDeclSeparator :: GHC.EpUniToken "::" "\8759" -> Maybe GHC.RealSrcSpan fieldDeclSeparator (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) _) = Just s fieldDeclSeparator _ = Nothing -------------------------------------------------------------------------------- squashMatch :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Editor.Edits squashMatch lmatch = case GHC.m_grhss match of GHC.GRHSs _ [lgrhs] _ | GHC.GRHS ext [] body <- GHC.unLoc lgrhs , Just left <- mbLeft , Just sep <- matchSeparator ext , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body -> squash left sep <> squash sep right _ -> mempty where match = GHC.unLoc lmatch mbLeft = case match of GHC.Match _ (GHC.FunRhs name _ _ _ ) (GHC.L _ []) _ -> GHC.srcSpanToRealSrcSpan $ GHC.getLocA name GHC.Match _ _ (GHC.L _ pats@(_ : _)) _ -> GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last pats _ -> Nothing -------------------------------------------------------------------------------- matchSeparator :: GHC.EpAnn GHC.GrhsAnn -> Maybe GHC.RealSrcSpan matchSeparator GHC.EpAnn {..} = case GHC.ga_sep anns of Left (GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan s _))) -> Just s Right (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan s _)) _) -> Just s _ -> Nothing -------------------------------------------------------------------------------- step :: Step step = makeStep "Squash" $ \ls module' -> let changes = foldMap squashFieldDecl (everything module') <> foldMap squashMatch (everything module') in Editor.apply changes ls stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/Tabs.hs0000644000000000000000000000126107346545000022720 0ustar0000000000000000-------------------------------------------------------------------------------- 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 stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs0000644000000000000000000000164307346545000025621 0ustar0000000000000000-------------------------------------------------------------------------------- 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 where dropTrailingWhitespace' l = case l of -- Preserve page breaks "\12" -> l _ -> dropTrailingWhitespace l stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs0000644000000000000000000000435107346545000024627 0ustar0000000000000000-------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step.UnicodeSyntax ( step ) where -------------------------------------------------------------------------------- import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import Language.Haskell.Stylish.Util (everything) -------------------------------------------------------------------------------- hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits hsTyReplacements (GHC.HsFunTy _ arr _ _) | GHC.HsUnrestrictedArrow (GHC.EpUniTok epaLoc GHC.NormalSyntax) <- arr = Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→" hsTyReplacements (GHC.HsQualTy _ ctx _) | Just arrow <- GHC.ac_darrow . GHC.anns $ GHC.getLoc ctx , (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan loc _)) GHC.NormalSyntax) <- arrow = Editor.replaceRealSrcSpan loc "⇒" hsTyReplacements _ = mempty -------------------------------------------------------------------------------- hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits hsSigReplacements (GHC.TypeSig ann _ _) | GHC.EpUniTok epaLoc _ <- GHC.asDcolon ann , GHC.EpaSpan (GHC.RealSrcSpan loc _) <- epaLoc = Editor.replaceRealSrcSpan loc "∷" hsSigReplacements _ = mempty -------------------------------------------------------------------------------- step :: Bool -> String -> Step step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines step' alp lg ls modu = Editor.apply edits ls where edits = foldMap hsTyReplacements (everything modu) <> foldMap hsSigReplacements (everything modu) <> (if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty) stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Util.hs0000644000000000000000000002014107346545000022027 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util ( indent , padRight , everything , trimLeft , trimRight , wrap , wrapRest , wrapMaybe , wrapRestMaybe -- * Extra list functions , withHead , withInit , withTail , withLast , flagEnds , traceOutputable , traceOutputableM , unguardedRhsBody , rhsBody , getGuards ) where -------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.Data (Data) import qualified Data.Generics as G import Data.Maybe (maybeToList) import Data.Typeable (cast) import Debug.Trace (trace) import qualified GHC.Hs as Hs import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- 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 :: [S.Located pass] -> [((Int, Int), (Int, Int))] infoPoints = fmap (helper . S.getLoc) where helper :: S.SrcSpan -> ((Int, Int), (Int, Int)) helper (S.RealSrcSpan s) = do let start = S.realSrcSpanStart s end = S.realSrcSpanEnd s ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end)) helper _ = ((-1,-1), (-1,-1)) -} -------------------------------------------------------------------------------- trimLeft :: String -> String trimLeft = dropWhile isSpace -------------------------------------------------------------------------------- trimRight :: String -> String trimRight = reverse . trimLeft . reverse -------------------------------------------------------------------------------- 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) -------------------------------------------------------------------------------- wrapMaybe :: Maybe Int -- ^ Maximum line width (maybe) -> String -- ^ Leading string -> Int -- ^ Indentation -> [String] -- ^ Strings to add/wrap -> Lines -- ^ Resulting lines wrapMaybe (Just maxWidth) = wrap maxWidth wrapMaybe Nothing = noWrap -------------------------------------------------------------------------------- noWrap :: String -- ^ Leading string -> Int -- ^ Indentation -> [String] -- ^ Strings to add -> Lines -- ^ Resulting lines noWrap leading _ind = noWrap' leading where noWrap' ss [] = [ss] noWrap' ss (str:strs) = noWrap' (ss ++ " " ++ str) strs -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- wrapRestMaybe :: Maybe Int -> Int -> [String] -> Lines wrapRestMaybe (Just maxWidth) = wrapRest maxWidth wrapRestMaybe Nothing = noWrapRest -------------------------------------------------------------------------------- noWrapRest :: Int -> [String] -> Lines noWrapRest ind = reverse . noWrapRest' [] "" where noWrapRest' ls ss [] | null ss = ls | otherwise = ss:ls noWrapRest' ls ss (str:strs) | null ss = noWrapRest' ls (indent ind str) strs | otherwise = noWrapRest' ls (ss ++ " " ++ str) strs -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- -- | Utility for traversing through a list and knowing when you're at the -- first and last element. flagEnds :: [a] -> [(a, Bool, Bool)] flagEnds = \case [] -> [] [x] -> [(x, True, True)] x : y : zs -> (x, True, False) : go (y : zs) where go (x : y : zs) = (x, False, False) : go (y : zs) go [x] = [(x, False, True)] go [] = [] -------------------------------------------------------------------------------- traceOutputable :: GHC.Outputable a => String -> a -> b -> b traceOutputable title x = trace (title ++ ": " ++ (showOutputable x)) -------------------------------------------------------------------------------- traceOutputableM :: (GHC.Outputable a, Monad m) => String -> a -> m () traceOutputableM title x = traceOutputable title x $ pure () -------------------------------------------------------------------------------- -- Utility: grab the body out of guarded RHSs if it's a single unguarded one. unguardedRhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a unguardedRhsBody (Hs.GRHSs _ [grhs] _) | Hs.GRHS _ [] body <- GHC.unLoc grhs = Just body unguardedRhsBody _ = Nothing -- Utility: grab the body out of guarded RHSs rhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a rhsBody (Hs.GRHSs _ [grhs] _) | Hs.GRHS _ _ body <- GHC.unLoc grhs = Just body rhsBody _ = Nothing -------------------------------------------------------------------------------- -- get guards in a guarded rhs of a Match getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] getGuards (Hs.Match _ _ _ grhss) = let lgrhs = getLocGRHS grhss -- [] grhs = map GHC.unLoc lgrhs in concatMap getGuardLStmts grhs getLocGRHS :: Hs.GRHSs Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.LGRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] getLocGRHS (Hs.GRHSs _ guardeds _) = guardeds getGuardLStmts :: Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] getGuardLStmts (Hs.GRHS _ guards _) = guards stylish-haskell-0.15.1.0/lib/Language/Haskell/Stylish/Verbose.hs0000644000000000000000000000114607346545000022523 0ustar0000000000000000-------------------------------------------------------------------------------- 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 () stylish-haskell-0.15.1.0/src/0000755000000000000000000000000007346545000014034 5ustar0000000000000000stylish-haskell-0.15.1.0/src/Main.hs0000644000000000000000000001443207346545000015260 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Main ( main ) where -------------------------------------------------------------------------------- import Control.Monad (forM_, unless, when) import qualified Data.ByteString.Char8 as BC8 import Data.Version (showVersion) import qualified Options.Applicative as OA import System.Exit (exitFailure) import qualified System.IO as IO import qualified System.IO.Strict as IO.Strict -------------------------------------------------------------------------------- import Language.Haskell.Stylish -------------------------------------------------------------------------------- data StylishArgs = StylishArgs { saVersion :: Bool , saConfig :: Maybe FilePath , saRecursive :: Bool , saVerbose :: Bool , saDefaults :: Bool , saInPlace :: Bool , saNoUtf8 :: Bool , saFiles :: [FilePath] } deriving (Show) -------------------------------------------------------------------------------- parseStylishArgs :: OA.Parser StylishArgs parseStylishArgs = StylishArgs <$> OA.switch ( OA.help "Show version information" <> OA.long "version" <> OA.hidden) <*> OA.optional (OA.strOption $ OA.metavar "CONFIG" <> OA.help "Configuration file" <> OA.long "config" <> OA.short 'c' <> OA.hidden) <*> OA.switch ( OA.help "Recursive file search" <> OA.long "recursive" <> OA.short 'r' <> OA.hidden) <*> OA.switch ( OA.help "Run in verbose mode" <> OA.long "verbose" <> OA.short 'v' <> OA.hidden) <*> OA.switch ( OA.help "Dump default config and exit" <> OA.long "defaults" <> OA.short 'd' <> OA.hidden) <*> OA.switch ( OA.help "Overwrite the given files in place" <> OA.long "inplace" <> OA.short 'i' <> OA.hidden) <*> OA.switch ( OA.help "Don't force UTF-8 stdin/stdout" <> OA.long "no-utf8" <> OA.hidden) <*> OA.many (OA.strArgument $ OA.metavar "FILENAME" <> OA.help "Input file(s)") -------------------------------------------------------------------------------- stylishHaskellVersion :: String stylishHaskellVersion = "stylish-haskell " <> showVersion version -------------------------------------------------------------------------------- parserInfo :: OA.ParserInfo StylishArgs parserInfo = OA.info (OA.helper <*> parseStylishArgs) $ OA.fullDesc <> OA.header stylishHaskellVersion -------------------------------------------------------------------------------- main :: IO () main = OA.execParser parserInfo >>= stylishHaskell -------------------------------------------------------------------------------- stylishHaskell :: StylishArgs -> IO () stylishHaskell sa = do unless (saNoUtf8 sa) $ mapM_ (`IO.hSetEncoding` IO.utf8) [IO.stdin, IO.stdout] if saVersion sa then putStrLn stylishHaskellVersion else if saDefaults sa then do verbose' "Dumping embedded config..." BC8.putStr defaultConfigBytes else do conf <- loadConfig verbose' $ maybe SearchFromCurrentDirectory UseConfig (saConfig sa) filesR <- case (saRecursive sa) of True -> findHaskellFiles (saVerbose sa) (saFiles sa) _ -> return $ saFiles sa let steps = configSteps conf forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" verbose' $ "Extra language extensions: " ++ show (configLanguageExtensions conf) res <- foldMap (file sa conf) (files' filesR) verbose' $ "Exit code behavior: " ++ show (configExitCode conf) when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat) exitFailure where verbose' = makeVerbose (saVerbose sa) files' x = case (saRecursive sa, null x) of (True,True) -> [] -- No file to format and recursive enabled. (_,True) -> [Nothing] -- Involving IO.stdin. (_,False) -> map Just x -- Process available files. data FormattingResult = DidFormat | NoChange deriving (Eq) instance Semigroup FormattingResult where _ <> DidFormat = DidFormat DidFormat <> _ = DidFormat _ <> _ = NoChange instance Monoid FormattingResult where mempty = NoChange -------------------------------------------------------------------------------- -- | Processes a single file, or stdin if no filepath is given file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult file sa conf mfp = do contents <- maybe getContents readUTF8File mfp let inputLines = lines contents result = runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines case result of Right ok -> do write contents (unlines ok) pure $ if ok /= inputLines then DidFormat else NoChange Left err -> do IO.hPutStrLn IO.stderr err exitFailure where write old new = case mfp of Nothing -> putStrNewline new Just _ | not (saInPlace sa) -> putStrNewline new Just path | not (null new) && old /= new -> IO.withFile path IO.WriteMode $ \h -> do setNewlineMode h IO.hPutStr h new _ -> return () setNewlineMode h = do let nl = configNewline conf let mode = IO.NewlineMode IO.nativeNewline nl IO.hSetNewlineMode h mode putStrNewline txt = setNewlineMode IO.stdout >> putStr txt readUTF8File :: FilePath -> IO String readUTF8File fp = IO.withFile fp IO.ReadMode $ \h -> do IO.hSetEncoding h IO.utf8 IO.Strict.hGetContents h stylish-haskell-0.15.1.0/stylish-haskell.cabal0000644000000000000000000001073707346545000017361 0ustar0000000000000000Cabal-version: 2.4 Name: stylish-haskell Version: 0.15.1.0 Synopsis: Haskell code prettifier Homepage: https://github.com/haskell/stylish-haskell License: BSD-3-Clause License-file: LICENSE Author: Jasper Van der Jeugt Maintainer: Jasper Van der Jeugt Copyright: 2012 Jasper Van der Jeugt Category: Language Build-type: Simple Description: A Haskell code prettifier. For more information, see: . Extra-source-files: README.markdown, data/stylish-haskell.yaml Extra-doc-files: CHANGELOG Flag ghc-lib Default: True Manual: True Description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported Common depends Ghc-options: -Wall Default-language: Haskell2010 Build-depends: aeson >= 0.6 && < 2.3, base >= 4.19 && < 5, bytestring >= 0.9 && < 0.13, Cabal >= 3.10 && < 4.0, containers >= 0.3 && < 0.9, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.6, file-embed >= 0.0.10 && < 0.1, mtl >= 2.0 && < 2.4, regex-tdfa >= 1.3 && < 1.4, syb >= 0.3 && < 0.8, text >= 1.2 && < 2.2, HsYAML-aeson >=0.2.0 && < 0.3, HsYAML >=0.2.0 && < 0.3, if impl(ghc < 8.0) Build-depends: semigroups >= 0.18 && < 0.20 -- Use GHC if the ghc-lib flag is not set -- and we have a new enough GHC. Note that -- this will only work if the user's -- compiler is of the matching major version! if !flag(ghc-lib) && impl(ghc >= 9.8) && impl(ghc < 9.13) Build-depends: ghc >= 9.12 && < 9.13, ghc-boot, ghc-boot-th else Build-depends: ghc-lib-parser >= 9.12 && < 9.13 Build-depends: ghc-lib-parser-ex >= 9.12 && < 9.13 Library Import: depends Hs-source-dirs: lib Exposed-modules: Language.Haskell.Stylish Language.Haskell.Stylish.Config Language.Haskell.Stylish.GHC Language.Haskell.Stylish.Module Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.SimpleAlign Language.Haskell.Stylish.Step.Squash Language.Haskell.Stylish.Step.Tabs Language.Haskell.Stylish.Step.TrailingWhitespace Language.Haskell.Stylish.Step.UnicodeSyntax Other-modules: Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block Language.Haskell.Stylish.Comments Language.Haskell.Stylish.Config.Cabal Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Editor Language.Haskell.Stylish.Ordering Language.Haskell.Stylish.Util Language.Haskell.Stylish.Verbose Paths_stylish_haskell Autogen-modules: Paths_stylish_haskell Executable stylish-haskell Import: depends Hs-source-dirs: src Main-is: Main.hs Build-depends: stylish-haskell, strict >= 0.3 && < 0.6, optparse-applicative >= 0.12 && < 0.19 Test-suite stylish-haskell-tests Import: depends Hs-source-dirs: tests Main-is: TestSuite.hs Type: exitcode-stdio-1.0 Other-modules: Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Regressions Language.Haskell.Stylish.Step.Data.Tests Language.Haskell.Stylish.Step.Imports.FelixTests Language.Haskell.Stylish.Step.Imports.Tests Language.Haskell.Stylish.Step.LanguagePragmas.Tests Language.Haskell.Stylish.Step.ModuleHeader.Tests Language.Haskell.Stylish.Step.SimpleAlign.Tests Language.Haskell.Stylish.Step.Squash.Tests Language.Haskell.Stylish.Step.Tabs.Tests Language.Haskell.Stylish.Step.TrailingWhitespace.Tests Language.Haskell.Stylish.Step.UnicodeSyntax.Tests Language.Haskell.Stylish.Tests Language.Haskell.Stylish.Tests.Util Build-depends: stylish-haskell, HUnit >= 1.2 && < 1.7, random >= 1.1, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, Source-repository head Type: git Location: https://github.com/haskell/stylish-haskell stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Config/0000755000000000000000000000000007346545000022361 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Config/Tests.hs0000644000000000000000000002065107346545000024023 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Config.Tests ( tests ) where -------------------------------------------------------------------------------- import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Set as Set import qualified Data.YAML.Aeson as Yaml import System.Directory import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@?=)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Config" [ testCase "Extensions extracted correctly from .cabal file" testExtensionsFromDotCabal , testCase "Extensions extracted correctly from .stylish-haskell.yaml file" testExtensionsFromDotStylish , testCase "Extensions extracted correctly from .stylish-haskell.yaml and .cabal files" testExtensionsFromBoth , testCase "NoXyz extensions from .stylish-haskell.yaml file" testStylishNoXyz , testCase "NoXyz extensions from .cabal file" testCabalNoXyz , testCase "Correctly read .stylish-haskell.yaml file with default max column number" testDefaultColumns , testCase "Correctly read .stylish-haskell.yaml file with specified max column number" testSpecifiedColumns , testCase "Correctly read .stylish-haskell.yaml file with no max column number" testNoColumns , testCase "Backwards-compatible align options" testBoolSimpleAlign ] -------------------------------------------------------------------------------- type ExtensionName = String data ConfigFile = ConfigFile { fileName :: FilePath , contents :: String , extensions :: [ExtensionName] } stylishCfg :: ([ExtensionName] -> String) -> [ExtensionName] -> ConfigFile stylishCfg template exts = ConfigFile { fileName = ".stylish-haskell.yaml" , contents = template exts , extensions = exts } cabalCfg :: ([ExtensionName] -> [ExtensionName] -> String) -> [ExtensionName] -> [ExtensionName] -> ConfigFile cabalCfg template exts1 exts2 = ConfigFile { fileName = "test.cabal" , contents = template exts1 exts2 , extensions = exts1 ++ exts2 } -------------------------------------------------------------------------------- testExtensions :: [ConfigFile] -> Assertion testExtensions cfgFiles = do cfg' <- createFilesAndGetConfig cfgFiles let expected = Set.fromList (concatMap extensions cfgFiles) actual = Set.fromList (configLanguageExtensions cfg') actual @?= expected testColumns :: Maybe Int -> [ConfigFile] -> Assertion testColumns expected cfgFiles = do cfg' <- createFilesAndGetConfig cfgFiles let actual = configColumns cfg' actual @?= expected -------------------------------------------------------------------------------- -- | Put an example config files (.cabal/.stylish-haskell.yaml/both) -- into the current directory and extract extensions from it. createFilesAndGetConfig :: [ConfigFile] -> IO Config createFilesAndGetConfig files = withTestDirTree $ do mapM_ (\ConfigFile{..} -> writeFile fileName contents) files -- create an empty directory and change into it createDirectory "src" setCurrentDirectory "src" -- from that directory read the config file and extract extensions -- to make sure the search for .cabal file works loadConfig (const (pure ())) SearchFromCurrentDirectory -------------------------------------------------------------------------------- testExtensionsFromDotCabal :: Assertion testExtensionsFromDotCabal = testExtensions [ cabalCfg dotCabal ["ScopedTypeVariables"] ["DataKinds"] ] -------------------------------------------------------------------------------- testExtensionsFromDotStylish :: Assertion testExtensionsFromDotStylish = testExtensions [ stylishCfg dotStylish ["TemplateHaskell", "QuasiQuotes"] ] -------------------------------------------------------------------------------- testExtensionsFromBoth :: Assertion testExtensionsFromBoth = testExtensions [ cabalCfg dotCabal ["ScopedTypeVariables"] ["DataKinds"] , stylishCfg dotStylish ["TemplateHaskell", "QuasiQuotes"] ] -------------------------------------------------------------------------------- testStylishNoXyz :: Assertion testStylishNoXyz = testExtensions [ stylishCfg dotStylish ["NoStarIsType", "NoTypeOperators"] ] -------------------------------------------------------------------------------- testCabalNoXyz :: Assertion testCabalNoXyz = testExtensions [ cabalCfg dotCabal ["NoStarIsType"] ["NoTypeOperators"] ] -------------------------------------------------------------------------------- testSpecifiedColumns :: Assertion testSpecifiedColumns = testColumns (Just 110) [ stylishCfg dotStylish [] ] -------------------------------------------------------------------------------- testDefaultColumns :: Assertion testDefaultColumns = testColumns (Just 80) [ stylishCfg dotStylish2 ["DataKinds"] ] -------------------------------------------------------------------------------- testNoColumns :: Assertion testNoColumns = testColumns Nothing [ stylishCfg dotStylish3 ["DataKinds"] ] -------------------------------------------------------------------------------- testBoolSimpleAlign :: Assertion testBoolSimpleAlign = do Right val <- pure $ Yaml.decode1 $ BL8.pack config Aeson.Success conf <- pure $ Aeson.parse parseConfig val length (configSteps conf) @?= 1 where config = unlines [ "steps:" , " - simple_align:" , " cases: true" , " top_level_patterns: always" , " records: false" ] -- | Example cabal file borrowed from -- https://www.haskell.org/cabal/users-guide/developing-packages.html -- with some default-extensions added dotCabal :: [ExtensionName] -> [ExtensionName] -> String dotCabal exts1 exts2 = unlines $ [ "name: TestPackage" , "version: 0.0" , "synopsis: Package with library and two programs" , "license: BSD3" , "author: Angela Author" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "library" , " build-depends: HUnit" , " exposed-modules: A, B, C" , " default-extensions:" ] ++ map (" " ++) exts1 ++ [ "" , "executable program1" , " main-is: Main.hs" , " hs-source-dirs: prog1" , " other-modules: A, B" , " default-extensions:" ] ++ map (" " ++) exts2 -- | Example .stylish-haskell.yaml dotStylish :: [ExtensionName] -> String dotStylish exts = unlines $ [ "steps:" , " - imports:" , " align: none" , " list_align: after_alias" , " long_list_align: inline" , " separate_lists: true" , " - language_pragmas:" , " style: vertical" , " align: false" , " remove_redundant: true" , " - trailing_whitespace: {}" , " - records:" , " equals: \"same_line\"" , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 4" , " via: \"indent 2\"" , "columns: 110" , "language_extensions:" ] ++ map (" - " ++) exts -- | Example .stylish-haskell.yaml dotStylish2 :: [ExtensionName] -> String dotStylish2 exts = unlines $ [ "steps:" , " - imports:" , " align: none" , " list_align: after_alias" , " long_list_align: inline" , " separate_lists: true" , " - language_pragmas:" , " style: vertical" , " align: false" , " remove_redundant: true" , " - trailing_whitespace: {}" , "language_extensions:" ] ++ map (" - " ++) exts -- | Example .stylish-haskell.yaml dotStylish3 :: [ExtensionName] -> String dotStylish3 exts = unlines $ [ "steps:" , " - imports:" , " align: none" , " list_align: after_alias" , " long_list_align: inline" , " separate_lists: true" , " - language_pragmas:" , " style: vertical" , " align: false" , " remove_redundant: true" , " - trailing_whitespace: {}" , "columns: null" , "language_extensions:" ] ++ map (" - " ++) exts stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Parse/0000755000000000000000000000000007346545000022226 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Parse/Tests.hs0000644000000000000000000001251207346545000023665 0ustar0000000000000000module Language.Haskell.Stylish.Parse.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertFailure) import GHC.Stack (HasCallStack, withFrozenCallStack) -------------------------------------------------------------------------------- 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 , testCase "ShebangExt" testShebangExt , testCase "ShebangDouble" testShebangDouble , testCase "GADTs extension" testGADTs , testCase "KindSignatures extension" testKindSignatures , testCase "StandalonDeriving extension" testStandaloneDeriving , testCase "UnicodeSyntax extension" testUnicodeSyntax , testCase "XmlSyntax regression" testXmlSyntaxRegression , testCase "MagicHash regression" testMagicHashRegression , testCase "Disabling extensions" testDisableExtensions , testCase "Safe extension" testSafeExtension ] -------------------------------------------------------------------------------- testShebangExt :: Assertion testShebangExt = returnsRight $ parseModule [] Nothing input where input = unlines [ "#!env runghc" , "{-# LANGUAGE CPP #-}" , "#define foo bar \\" , " qux" ] -------------------------------------------------------------------------------- testBom :: Assertion testBom = returnsRight $ parseModule [] Nothing input where input = unlines [ '\xfeff' : "foo :: Int" , "foo = 3" ] -------------------------------------------------------------------------------- testExtraExtensions :: Assertion testExtraExtensions = returnsRight $ parseModule ["TemplateHaskell"] Nothing "$(foo)" -------------------------------------------------------------------------------- testMultilineCpp :: Assertion testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE CPP #-}" , "#define foo bar \\" , " qux" ] -------------------------------------------------------------------------------- testHaskell2010 :: Assertion testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE Haskell2010 #-}" , "module X where" , "foo x | Just y <- x = y" ] -------------------------------------------------------------------------------- testShebang :: Assertion testShebang = returnsRight $ parseModule [] Nothing $ unlines [ "#!runhaskell" , "module Main where" , "main = return ()" ] -------------------------------------------------------------------------------- testShebangDouble :: Assertion testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines [ "#!nix-shell" , "#!nix-shell -i runhaskell -p haskellPackages.ghc" , "module Main where" , "main = return ()" ] -------------------------------------------------------------------------------- -- | These tests are for syntactic language extensions that should always be -- enabled for parsing, even when the pragma is absent. testGADTs :: Assertion testGADTs = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data SafeList a b where" , " Nil :: SafeList a Empty" , " Cons:: a -> SafeList a b -> SafeList a NonEmpty" ] testKindSignatures :: Assertion testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data D :: * -> * -> * where" , " D :: a -> b -> D a b" ] testStandaloneDeriving :: Assertion testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "deriving instance Show MyType" ] testUnicodeSyntax :: Assertion testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "monadic ∷ (Monad m) ⇒ m a → m a" , "monadic = id" ] testXmlSyntaxRegression :: Assertion testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines [ "smaller a b = a Show a => Either a b -> Assertion returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/0000755000000000000000000000000007346545000021154 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Regressions.hs0000644000000000000000000000205507346545000024015 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Regressions ( tests ) where import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util (assertSnippet) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) tests :: Test tests = testGroup "Language.Haskell.Stylish.Regressions" [ testCase "case 00 (issue #198)" case00 ] -- | Error parsing '(,) #198 -- -- See https://github.com/haskell/stylish-haskell/issues/198 case00 :: Assertion case00 = assertSnippet (step (Just 80) $ importStepConfig Global) input input where input = [ "{-# LANGUAGE TemplateHaskell #-}" , "" , "import Language.Haskell.TH.Syntax" , "" , "main = print $ showName '(,)" ] importStepConfig :: ImportAlign -> Options importStepConfig align = defaultOptions { importAlign = align } stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Data/0000755000000000000000000000000007346545000022740 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Data/Tests.hs0000644000000000000000000011403107346545000024376 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Step.Data.Tests ( tests ) where import Language.Haskell.Stylish.Step.Data import Language.Haskell.Stylish.Tests.Util (assertSnippet) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" [ testCase "case 00" case00 , 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 , testCase "case 19" case19 , testCase "case 20 (issue #262)" case20 , testCase "case 21" case21 , testCase "case 22" case22 , testCase "case 23" case23 , testCase "case 24" case24 , testCase "case 25" case25 , testCase "case 26" case26 , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 , testCase "case 30" case30 , testCase "case 31" case31 , testCase "case 32" case32 , testCase "case 33" case33 , testCase "case 34" case34 , testCase "case 35" case35 , testCase "case 36" case36 , testCase "case 37" case37 , testCase "case 38" case38 , testCase "case 39" case39 , testCase "case 40" case40 , testCase "case 41" case41 , testCase "case 42" case42 , testCase "case 43" case43 , testCase "case 44" case44 , testCase "case 45" case45 , testCase "case 46" case46 , testCase "case 47" case47 , testCase "case 48" case48 , testCase "case 49" case49 , testCase "case 50" case50 , testCase "case 51" case51 , testCase "case 52" case52 , testCase "case 53" case53 , testCase "case 54" case54 , testCase "case 55" case55 , testCase "case 56" case56 , testCase "case 57" case57 , testCase "case 58" case58 , testCase "case 59" case59 , testCase "case 60" case60 , testCase "case 61 (issue #282)" case61 , testCase "case 62 (issue #273)" case62 , testCase "case 63 (issue #338)" case63 , testCase "case 64" case64 , testCase "case 65" case65 , testCase "case 66 (issue #411)" case66 ] case00 :: Assertion case00 = assertSnippet (step sameSameStyle) input input where input = [ "module Herp where" , "" , "data Foo" ] case01 :: Assertion case01 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo = Foo { a :: Int }" ] [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " }" ] case02 :: Assertion case02 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo = Foo { a :: Int, a2 :: String }" ] [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " , a2 :: String" , " }" ] case03 :: Assertion case03 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo { a :: a, a2 :: String }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { a :: a" , " , a2 :: String" , " }" ] case04 :: Assertion case04 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo { a :: a, a2 :: String } | Bar { b :: a }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { a :: a" , " , a2 :: String" , " }" , " | Bar" , " { b :: a" , " }" ] case05 :: Assertion case05 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo = Foo {" , " a :: Int" , " , a2 :: String" , " }" ] [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " , a2 :: String" , " }" ] case06 :: Assertion case06 = assertSnippet (step sameSameStyle) input input where input = [ "module Herp where" , "" , "data Foo = Foo Int String" ] case07 :: Assertion case07 = assertSnippet (step sameSameStyle) input input where input = [ "module Herp where" , "" , "data Phantom a = Phantom" ] case08 :: Assertion case08 = assertSnippet (step sameSameStyle) [ "module Herp where" , "" , "data Phantom a =" , " Phantom" ] [ "module Herp where" , "" , "data Phantom a = Phantom" ] case09 :: Assertion case09 = assertSnippet (step indentIndentStyle4) [ "module Herp where" , "" , "data Foo a b = Foo { a :: a, a2 :: String } | Bar { b :: a, c:: b }" ] [ "module Herp where" , "" , "data Foo a b" , " = Foo" , " { a :: a" , " , a2 :: String" , " }" , " | Bar" , " { b :: a" , " , c :: b" , " }" ] case10 :: Assertion case10 = assertSnippet (step indentIndentStyle) input expected where input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving (Eq, Generic) deriving (Show)" ] expected = [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " }" , " deriving (Eq, Generic)" , " deriving (Show)" ] case11 :: Assertion case11 = assertSnippet (step indentIndentStyle) input expected where input = [ "{-# LANGUAGE DerivingStrategies #-}" , "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving stock (Show)" ] expected = [ "{-# LANGUAGE DerivingStrategies #-}" , "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " }" , " deriving stock (Show)" ] case12 :: Assertion case12 = assertSnippet (step indentIndentStyle4) input expected where input = [ "module Herp where" , "" , "data Point = Point { pointX, pointY :: Double , pointName :: String} deriving (Show)" ] expected = [ "module Herp where" , "" , "data Point" , " = Point" , " { pointX, pointY :: Double" , " , pointName :: String" , " }" , " deriving (Show)" ] case13 :: Assertion case13 = assertSnippet (step indentIndentStyle) input expected where input = [ "module Herp where" , "" , "-- this is a comment" , "data Foo = Foo { a :: Int }" ] expected = [ "module Herp where" , "" , "-- this is a comment" , "data Foo" , " = Foo" , " { a :: Int" , " }" ] case14 :: Assertion case14 = assertSnippet (step indentIndentStyle) input expected where input = [ "module Herp where" , "" , "{- this is" , " a comment -}" , "data Foo = Foo { a :: Int }" ] expected = [ "module Herp where" , "" , "{- this is" , " a comment -}" , "data Foo" , " = Foo" , " { a :: Int" , " }" ] case15 :: Assertion case15 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo" , " { a :: a, -- comment" , " a2 :: String" , " }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { a :: a" , " -- comment" , " , a2 :: String" , " }" ] case16 :: Assertion case16 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo = Foo {" , " a :: Int -- ^ comment" , " }" ] [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " -- ^ comment" , " }" ] case17 :: Assertion case17 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo" , " { a :: a," , "-- comment" , " a2 :: String" , " }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { a :: a" , " -- comment" , " , a2 :: String" , " }" ] case18 :: Assertion case18 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo" , " { a :: a," , "-- ^ comment" , " a2 :: String" , " }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { a :: a" , " -- ^ comment" , " , a2 :: String" , " }" ] case19 :: Assertion case19 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo" , " { firstName, lastName :: String," , "-- ^ names" , " age :: Int" , " }" ] [ "module Herp where" , "" , "data Foo a" , " = Foo" , " { firstName, lastName :: String" , " -- ^ names" , " , age :: Int" , " }" ] -- | Should not break Enums (data without records) formatting -- -- See https://github.com/haskell/stylish-haskell/issues/262 case20 :: Assertion case20 = assertSnippet (step indentIndentStyle) input input where input = [ "module Herp where" , "" , "data Tag = Title | Text" , " deriving (Eq, Show)" ] case21 :: Assertion case21 = assertSnippet (step sameSameStyle) [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a } deriving (Eq, Show)" , " deriving (ToJSON)" ] [ "data Foo a = Foo { a :: Int" , " , a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] case22 :: Assertion case22 = assertSnippet (step sameIndentStyle) [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a } deriving (Eq, Show)" , " deriving (ToJSON)" ] [ "data Foo a = Foo" , " { a :: Int" , " , a2 :: String" , " -- ^ some haddock" , " }" , " | Bar" , " { b :: a" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] case23 :: Assertion case23 = assertSnippet (step indentSameStyle) [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a } deriving (Eq, Show)" , " deriving (ToJSON)" ] [ "data Foo a" , " = Foo { a :: Int" , " , a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] case24 :: Assertion case24 = assertSnippet (step indentIndentStyle) [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" , " -- ^ some haddock" , " }" , " | Bar { b :: a } deriving (Eq, Show)" , " deriving (ToJSON)" ] [ "data Foo a" , " = Foo" , " { a :: Int" , " , a2 :: String" , " -- ^ some haddock" , " }" , " | Bar" , " { b :: a" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] case25 :: Assertion case25 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False }) input expected where input = [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" , " -- ^ some haddock" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] expected = [ "data Foo a = Foo" , " { a :: Int" , " , a2 :: String" , " -- ^ some haddock" , " }" , " deriving (Eq, Show)" , " deriving (ToJSON)" ] case26 :: Assertion case26 = assertSnippet (step indentIndentStyle) input expected where input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo" ] expected = [ "module Herp where" , "" , "data Foo" , " = Foo" , " { a :: Int" , " }" , " deriving (FromJSON) via Bla Foo" ] case27 :: Assertion case27 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where input = [ "module Herp where" , "" , "data Foo = Foo | Bar | Baz deriving (Eq, Show)" ] expected = [ "module Herp where" , "" , "data Foo" , " = Foo" , " | Bar" , " | Baz" , " deriving (Eq, Show)" ] case28 :: Assertion case28 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where input = [ "module Some.Types where" , "" , "newtype BankCode = BankCode {" , " unBankCode :: Text" , " }" , " deriving stock (Generic, Eq, Show)" , " deriving anyclass (Newtype)" , "" , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" , " deriving stock (Generic, Eq, Show)" , " deriving anyclass (Newtype)" , "" , "newtype WrappedInt = WrappedInt Int" , " deriving stock (Generic, Eq, Show)" , " deriving anyclass (Newtype)" , "" , "data MandateStatus" , " = Approved" , " | Failed" , " | UserCanceled" , " | Inactive" , " deriving stock (Generic, Show, Eq, Enum, Bounded)" , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] expected = [ "module Some.Types where" , "" , "newtype BankCode = BankCode { unBankCode :: Text }" , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "newtype WrappedInt = WrappedInt Int" , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "data MandateStatus" , " = Approved" , " | Failed" , " | UserCanceled" , " | Inactive" , " deriving stock (Bounded, Enum, Eq, Generic, Show)" , " deriving (FromJSON, ToJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] case29 :: Assertion case29 = assertSnippet (step sameIndentStyle) input expected where input = [ "module Some.Types where" , "" , "data NonEmpty a" , " = a :| [a]" ] expected = [ "module Some.Types where" , "" , "data NonEmpty a = a :| [a]" ] case30 :: Assertion case30 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where expected = input input = [ "data ReasonCode" , " = MissingTenantId" , " -- Transaction errors:" , " | TransactionDoesNotExist" , " | TransactionAlreadyExists" , " -- Engine errors:" , " | EnginePersistenceError" , " | EngineValidationError" , " -- | Transaction was created in Info mode" , " | RegisteredByNetworkEngine" , " -- | Transaction was created in Routing mode" , " | SentToNetworkEngine" , " -- Network connection reasons:" , " | SentToNetworkConnection" , " | ReceivedByNetworkConnection" , " | ValidatedByNetworkConnection" ] case31 :: Assertion case31 = assertSnippet (step indentIndentStyle { cBreakEnums = True }) input expected where expected = input input = [ "data ConfiguredLogger" , " -- | Logs to file" , " = LogTo FilePath" , " -- | Logs to stdout" , " | LogToConsole" , " -- | No logging, discards all messages" , " | NoLogging" , " deriving stock (Generic, Show)" ] case32 :: Assertion case32 = assertSnippet (step indentIndentStyle { cBreakEnums = True }) input expected where expected = input input = [ "data RejectionReason" , " -- InvalidState" , " = CancellationFailed" , " | TotalAmountConfirmationInvalid" , " -- InvalidApiUsage" , " | AccessTokenNotActive" , " | VersionNotFound" , " -- ValidationFailed" , " | BankAccountExists" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" ] case33 :: Assertion case33 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where input = [ "module Some.Types where" , "" , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" ] expected = [ "module Some.Types where" , "" , "newtype NonEmpty a" , " = NonEmpty { unNonEmpty :: a }" ] case34 :: Assertion case34 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where input = [ "module Some.Types where" , "" , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" , " deriving (ToJSON, FromJSON) via Something Magic (NonEmpty a)" ] expected = [ "module Some.Types where" , "" , "newtype NonEmpty a" , " = NonEmpty { unNonEmpty :: a }" , " deriving (FromJSON, ToJSON)" , " via Something Magic (NonEmpty a)" ] case35 :: Assertion case35 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where input = [ "module Some.Types where" , "" , "data Foo = Foo" , " { _transfer :: MonetaryAmount" , " -> TransactionId" , " -> m (Either CreditTransferError TransactionId)" , " }" ] expected = [ "module Some.Types where" , "" , "data Foo = Foo" , " { _transfer :: MonetaryAmount -> TransactionId -> m (Either CreditTransferError TransactionId)" , " }" ] case36 :: Assertion case36 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where input = [ "module Some.Types where" , "" , "data Foo = Foo" , " { _transfer :: (a -> b)" , " -> TransactionId" , " -> m (Either CreditTransferError TransactionId)" , " }" ] expected = [ "module Some.Types where" , "" , "data Foo = Foo" , " { _transfer :: (a -> b) -> TransactionId -> m (Either CreditTransferError TransactionId)" , " }" ] case37 :: Assertion case37 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where input = [ "module Some.Types where" , "" , "newtype UndoFlowData" , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" , " deriving stock (Generic, Eq, Show)" , " deriving (ToJSON, FromJSON)" , " via AddConstTextFields '[\"type0\" := \"undo\"," , " \"type1\" := \"undo\"," , " \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] expected = [ "module Some.Types where" , "" , "newtype UndoFlowData" , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] case38 :: Assertion case38 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where input = [ "data Flat = Flat" , " { foo :: Int" , " , bar :: Text" , " , baz :: Double" , " , qux :: Bool" , " }" , " deriving stock (Generic, Show, Eq)" , " deriving (FromJSON, ToJSON)" , " via GenericEncoded" , " '[ FieldLabelModifier :=" , " '[ \"foo\" ==> \"nestFoo#foo\"" , " , \"bar\" ==> \"nestBar#bar\"" , " , \"baz\" ==> \"nestFoo#baz\"" , " ]" , " ]" , " Flat" ] expected = [ "data Flat" , " = Flat" , " { foo :: Int" , " , bar :: Text" , " , baz :: Double" , " , qux :: Bool" , " }" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat" ] case39 :: Assertion case39 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where input = [ "data CreditTransfer = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" , " }" , " deriving stock (Show, Eq, Generic)" , " deriving (ToJSON, FromJSON) via" , " ( UntaggedEncoded NordeaCreditTransfer" , " & AddConstTextFields" , " '[ \"request_type\" ':= \"credit_transfer\"" , " , \"provider\" ':= \"nordea\"" , " ]" , " & FlattenFields '[\"nested_creditor_info\"]" , " & RenameKeys" , " '[ \"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\"" , " , \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\"" , " , \"nested_creditor_info.creditor_name\" ==> \"creditor_name\"" , " , \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"" , " ]" , " )" ] expected = [ "data CreditTransfer" , " = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" , " }" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" ] case40 :: Assertion case40 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False }) input expected where input = [ "module X where" , "" , "data a :==> b =" , " Arr a b" ] expected = [ "module X where" , "" , "data a :==> b = Arr a b" ] case41 :: Assertion case41 = assertSnippet (step indentIndentStyle) input expected where input = expected expected = [ "module X where" , "" , "data Callback" , " -- | Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" , " -- incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" , " -- nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." , " -- Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore" , " -- eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident," , " -- sunt in culpa qui officia deserunt mollit anim id est laborum." , " = KafkaTopic" , " { callbackTopic :: CallbackTopic" , " -- ^ Name of topic to send updates to" , " , callbackFormat :: CallbackFormat" , " -- ^ The format used to send these updates" , " }" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON) via IdiomaticWithDescription CallbackDesc Callback" , " deriving (HasGen) via Generically Callback" , " deriving (FromField) via JsonField Callback" ] case42 :: Assertion case42 = assertSnippet (step indentIndentStyle) input expected where input = expected expected = [ "module X where" , "" , "data SignupError" , " = IdempotencyConflict" , " | ValidationError Text -- TODO: might be a sumtype of possible error codes" , " deriving stock (Eq, Generic, Show)" ] case43 :: Assertion case43 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where input = expected expected = [ "module X where" , "" , "data CallbackResult" , " -- | Callback successfully sent" , " = Success" , " -- | Kafka error received" , " | KafkaIssue KafkaError" , " deriving (Eq, Show)" ] -- This test showcases a difficult to solve issue. If the comment is in a -- deriving clause, it's very hard to guess the correct position of the entire -- block. E.g. the deriving clause itself has the wrong position. However, if -- we look at all deriving clauses we know where they start and end. -- -- This means that we've needed to make the decision to put all inline comments -- before the deriving clause itself case44 :: Assertion case44 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where input = [ "module X where" , "" , " data CreditTransfer = CreditTransfer" , " { amount :: Amount -- ^ 1 <= amount <= 999_999_999_999" , " , date :: Day" , " , accountNumber :: Account" , " }" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON) via" , " AddConstTextFields" , " '[\"notification_type\" ':= \"credit_transaction\"" , " -- Note that the bcio name has \"transaction\"" , " -- rather than \"transfer\"" , " ]" , " (UntaggedEncoded CreditTransfer)" ] expected = [ "module X where" , "" , "data CreditTransfer = CreditTransfer" , " { amount :: Amount" , " -- ^ 1 <= amount <= 999_999_999_999" , " , date :: Day" , " , accountNumber :: Account" , " }" , " -- Note that the bcio name has \"transaction\"" , " -- rather than \"transfer\"" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] case45 :: Assertion case45 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where input = expected expected = [ "module X where" , "" , "data CreditTransfer = CreditTransfer" , " { amount :: Amount" , " -- ^ 1 <= amount <= 999_999_999_999" , " , date :: Day" , " , accountNumber :: Account" , " }" , " -- Note that the bcio name has \"transaction\"" , " -- rather than \"transfer\"" , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] case46 :: Assertion case46 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where input = expected expected = [ "module X where" , "" , "-- | A format detailing which encoding to use for the settlement events" , "data CallbackFormat" , " -- | The Avro schema is to be used" , " = AvroEngineEvent" , " deriving (Bounded, Enum, Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via TypeTaggedWithDescription FormatDesc CallbackFormat" , " deriving (HasGen)" , " via EnumBounded CallbackFormat" ] case47 :: Assertion case47 = assertSnippet (step indentIndentStyle) input expected where input = expected expected = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: (a, a) -> T [a]" ] case48 :: Assertion case48 = assertSnippet (step indentIndentStyle) input expected where input = expected expected = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: forall a. (Eq a, Bounded a) => (a, a) -> T [a]" ] case49 :: Assertion case49 = assertSnippet (step indentIndentStyle) input expected where input = expected expected = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" ] case50 :: Assertion case50 = assertSnippet (step indentIndentStyle { cCurriedContext = True }) input expected where input = expected expected = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: forall a. Eq a => (a, a) -> T [a]" ] case51 :: Assertion case51 = assertSnippet (step indentIndentStyle { cCurriedContext = True }) input expected where input = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" ] expected = [ "module X where" , "" , "-- | A GADT example" , "data T a where" , " D1 :: Int -> T String" , " D2 :: T Bool" , " D3 :: forall a. Eq a => (a, a) -> T [a]" ] case52 :: Assertion case52 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input expected where input = [ "module X where" , "" , "data Foo = Foo" , " { foo :: forall a b. (Eq a, Bounded b) => a -> b -> [(a, b)]" , " }" ] expected = [ "module X where" , "" , "data Foo = Foo" , " { foo :: forall a b. Eq a => Bounded b => a -> b -> [(a, b)]" , " }" ] case53 :: Assertion case53 = assertSnippet (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input expected where input = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Functor, Applicative, Monad, MonadError, MonadCatch, Foldable, Monoid)" ] expected = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype" , " ( Applicative" , " , Foldable" , " , Functor" , " , Monad" , " , MonadCatch" , " , MonadError" , " , Monoid" , " )" ] case54 :: Assertion case54 = assertSnippet (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input expected where input = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Functor, Applicative, Monad)" ] expected = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Applicative, Functor, Monad)" ] case55 :: Assertion case55 = assertSnippet (step sameSameNoSortStyle) input expected where input = [ "data Foo = Foo" , " deriving (Z, Y, X, Bar, Abcd)" ] expected = input case56 :: Assertion case56 = assertSnippet (step defaultConfig) [ "data Foo = Foo" , " { -- | Comment" , " bar :: Int" , " , baz :: Int" , " }" ] [ "data Foo = Foo" , " { -- | Comment" , " bar :: Int" , " , baz :: Int" , " }" ] case57 :: Assertion case57 = assertSnippet (step defaultConfig) [ "data Foo = Foo" , " { {- | A" , " -}" , " fooA :: Int" , "" , " {- | B" , " -}" , " , fooB :: Int" , "" , " {- | C" , " -}" , " , fooC :: Int" , "" , " {- | D" , " -}" , " , fooD :: Int" , "" , " {- | E" , " -}" , " , fooE :: Int" , "" , " {- | F" , " -}" , " , fooFooFoo :: Int" , "" , " {- | G" , " -}" , " , fooBarBar :: Int" , " }" ] [ "data Foo = Foo" , " { {- | A" , " -}" , " fooA :: Int" , " {- | B" , " -}" , " , fooB :: Int" , " {- | C" , " -}" , " , fooC :: Int" , " {- | D" , " -}" , " , fooD :: Int" , " {- | E" , " -}" , " , fooE :: Int" , " {- | F" , " -}" , " , fooFooFoo :: Int" , " {- | G" , " -}" , " , fooBarBar :: Int" , " }" ] -- | Should not break DataKinds in records -- -- See https://github.com/haskell/stylish-haskell/issues/330 case58 :: Assertion case58 = assertSnippet (step sameIndentStyle) input expected where input = [ "module Herp where" , "" , "data Foo a = Foo" , " { foo :: Foo 'True" , " }" ] expected = input -- | Don't remove existential quantification -- -- See https://github.com/haskell/stylish-haskell/issues/339 case59 :: Assertion case59 = assertSnippet (step defaultConfig) [ "data Foo = forall (a :: *) . Bar a" ] [ "data Foo = forall (a :: *). Bar a" ] -- | Don't remove existential quantification -- -- See https://github.com/haskell/stylish-haskell/issues/339 case60 :: Assertion case60 = assertSnippet (step defaultConfig) [ "data Foo = forall a . Bar a" ] [ "data Foo = forall a. Bar a" ] -- | Formatting duplicates haddock comments #282 -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/282 case61 :: Assertion case61 = assertSnippet (step sameIndentStyle) input expected where input = [ "module Herp where" , "" , "data Game = Game { _board :: Board -- ^ Board state" , " , _time :: Int -- ^ Time elapsed" , " , _paused :: Bool -- ^ Playing vs. paused" , " , _speed :: Float -- ^ Speed in [0..1]" , " , _interval :: TVar Int -- ^ Interval kept in TVar" , " }" ] expected = [ "module Herp where" , "" , "data Game = Game" , " { _board :: Board" , " -- ^ Board state" , " , _time :: Int" , " -- ^ Time elapsed" , " , _paused :: Bool" , " -- ^ Playing vs. paused" , " , _speed :: Float" , " -- ^ Speed in [0..1]" , " , _interval :: TVar Int" , " -- ^ Interval kept in TVar" , " }" ] -- | Comment issues with record formatting #273 -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/273 case62 :: Assertion case62 = assertSnippet (step sameIndentStyle) [ "module Herp where" , "" , "data Foo = Foo" , " { -- | This is a comment above some line." , " -- It can span multiple lines." , " fooName :: String" , " , fooAge :: Int" , " -- ^ This is a comment below some line." , " -- It can span multiple lines." , " }" ] [ "module Herp where" , "" , "data Foo = Foo" , " { -- | This is a comment above some line." , " -- It can span multiple lines." , " fooName :: String" , " , fooAge :: Int" , " -- ^ This is a comment below some line." , " -- It can span multiple lines." , " }" ] case63 :: Assertion case63 = assertSnippet (step indentIndentStyle) input expected where input = [ "module Herp where" , "" , "data Foo :: * -> * where" , " Bar :: () -> Foo ()" ] expected = input case64 :: Assertion case64 = assertSnippet (step indentIndentStyle) input input where input = [ "data Foo" , " = Bar Int" , " -- ^ Following comment" , " | Qux Int" , " -- ^ Second following comment" , " deriving (Show)" ] case65 :: Assertion case65 = assertSnippet (step indentIndentStyle) input input where input = [ "data Foo" , " = Bar" , " -- ^ Following comment" , " | Qux" , " -- ^ Second following comment" , " deriving (Show)" ] -- | Deriving alignment for enums -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/411 case66 :: Assertion case66 = assertSnippet (step indentIndentStyle) input input where input = [ "data Foo = A | B | C" , " deriving (Eq, Show)" ] sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns sameSameNoSortStyle :: Config sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Imports/0000755000000000000000000000000007346545000023524 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs0000644000000000000000000002374107346545000026161 0ustar0000000000000000-------------------------------------------------------------------------------- -- | Tests contributed by Felix Mulder as part of -- . {-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Imports.FelixTests ( tests ) where -------------------------------------------------------------------------------- import Prelude hiding (lines) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util (assertSnippet) -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.Imports.FelixTests" [ testCase "Hello world" ex0 , testCase "Sorted simple" ex1 , testCase "Sorted import lists" ex2 , testCase "Sorted import lists and import decls" ex3 , testCase "Import constructor all" ex4 , testCase "Import constructor specific" ex5 , testCase "Import constructor specific sorted" ex6 , testCase "Imports step does not change rest of file" ex7 , testCase "Imports respect groups" ex8 , testCase "Imports respects whitespace between groups" ex9 , testCase "Doesn't add extra space after 'hiding'" ex10 , testCase "Should be able to format symbolic imports" ex11 , testCase "Able to merge equivalent imports" ex12 , testCase "Obeys max columns setting" ex13 , testCase "Obeys max columns setting with two in each" ex14 , testCase "Respects multiple groups" ex15 , testCase "Doesn't delete nullary imports" ex16 ] -------------------------------------------------------------------------------- ex0 :: Assertion ex0 = assertSnippet (step Nothing felixOptions) [ "import B" , "import A" ] [ "import A" , "import B" ] ex1 :: Assertion ex1 = assertSnippet (step Nothing felixOptions) [ "import B" , "import A" , "import C" , "import qualified A" , "import qualified B as X" ] [ "import A" , "import qualified A" , "import B" , "import qualified B as X" , "import C" ] ex2 :: Assertion ex2 = assertSnippet (step Nothing felixOptions) [ "import B" , "import A (X)" , "import C" , "import qualified A as Y (Y)" ] [ "import A (X)" , "import qualified A as Y (Y)" , "import B" , "import C" ] ex3 :: Assertion ex3 = assertSnippet (step Nothing felixOptions) [ "import B" , "import A (X, Z, Y)" , "import C" , "import qualified A as A0 (b, Y, a)" , "import qualified D as D0 (Y, b, a)" , "import qualified E as E0 (b, a, Y)" ] [ "import A (X, Y, Z)" , "import qualified A as A0 (Y, a, b)" , "import B" , "import C" , "import qualified D as D0 (Y, a, b)" , "import qualified E as E0 (Y, a, b)" ] ex4 :: Assertion ex4 = assertSnippet (step Nothing felixOptions) [ "import A (X, Z(..), Y)" ] [ "import A (X, Y, Z (..))" ] ex5 :: Assertion ex5 = assertSnippet (step Nothing felixOptions) [ "import A (X, Z(Z), Y)" ] [ "import A (X, Y, Z (Z))" ] ex6 :: Assertion ex6 = assertSnippet (step Nothing felixOptions) [ "import A (X, Z(X, Z, Y), Y)" ] [ "import A (X, Y, Z (X, Y, Z))" ] ex7 :: Assertion ex7 = assertSnippet (step Nothing felixOptions) [ "module Foo (tests) where" , "import B" , "import A (X, Z, Y)" , "import C" , "import qualified A as A0 (b, Y, a)" , "import qualified D as D0 (Y, b, a)" , "import qualified E as E0 (b, a, Y)" , "-- hello" , "foo :: Int" , "foo = 1" ] [ "module Foo (tests) where" , "import A (X, Y, Z)" , "import qualified A as A0 (Y, a, b)" , "import B" , "import C" , "import qualified D as D0 (Y, a, b)" , "import qualified E as E0 (Y, a, b)" , "-- hello" , "foo :: Int" , "foo = 1" ] ex8 :: Assertion ex8 = assertSnippet (step Nothing felixOptions) [ "import B" , "-- Group divisor" , "import A (X)" , "import C" , "import qualified A as Y (Y)" ] [ "import B" , "-- Group divisor" , "import A (X)" , "import qualified A as Y (Y)" , "import C" ] ex9 :: Assertion ex9 = assertSnippet (step Nothing felixOptions) [ "--------" , "import B" , "" , "-- Group divisor" , "import A (X)" , "import C" , "import qualified A as Y (Y)" ] [ "--------" , "import B" , "" , "-- Group divisor" , "import A (X)" , "import qualified A as Y (Y)" , "import C" ] ex10 :: Assertion ex10 = assertSnippet (step Nothing felixOptions) [ "import B hiding (X)" , "import A hiding (X)" ] [ "import A hiding (X)" , "import B hiding (X)" ] ex11 :: Assertion ex11 = assertSnippet (step Nothing felixOptions) [ "import Data.Aeson ((.=))" , "import A hiding (X)" ] [ "import A hiding (X)" , "import Data.Aeson ((.=))" ] ex12 :: Assertion ex12 = assertSnippet (step Nothing felixOptions) [ "import Data.Aeson ((.=))" , "import Data.Aeson ((.=))" , "import A hiding (X)" ] [ "import A hiding (X)" , "import Data.Aeson ((.=))" ] ex13 :: Assertion ex13 = assertSnippet (step (Just 10) felixOptions) [ "import Foo (A, B, C, D)" , "import A hiding (X)" ] [ "import A hiding (X)" , "import Foo (A)" , "import Foo (B)" , "import Foo (C)" , "import Foo (D)" ] ex14 :: Assertion ex14 = assertSnippet (step (Just 27) felixOptions) [ "import Foo (A, B, C, D)" , "import A hiding (X)" ] [ "import A hiding (X)" , "import Foo (A, B)" , "import Foo (C, D)" ] ex15 :: Assertion ex15 = assertSnippet (step (Just 100) felixOptions) [ "module Custom.Prelude" , " ( LazyByteString" , " , UUID" , " , decodeUtf8Lenient" , " , error" , " , headMay" , " , module X" , " , nextRandomUUID" , " , onChars" , " , proxyOf" , " , show" , " , showStr" , " , toLazyByteString" , " , toStrictByteString" , " , type (~>)" , " , uuidToText" , " ) where" , "" , "--------------------------------------------------------------------------------" , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" , "import qualified Prelude" , "" , "--------------------------------------------------------------------------------" , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans, set, to, view)" , "import Control.Lens.Extras as X (is)" , "" , "--------------------------------------------------------------------------------" , "import Control.Applicative as X ((<|>))" , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" , "import Control.Monad.IO.Unlift as X" , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" , "--------------------------------------------------------------------------------" ] [ "module Custom.Prelude" , " ( LazyByteString" , " , UUID" , " , decodeUtf8Lenient" , " , error" , " , headMay" , " , module X" , " , nextRandomUUID" , " , onChars" , " , proxyOf" , " , show" , " , showStr" , " , toLazyByteString" , " , toStrictByteString" , " , type (~>)" , " , uuidToText" , " ) where" , "" , "--------------------------------------------------------------------------------" , "import Prelude as X hiding (appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile, (!!))" , "import qualified Prelude" , "" , "--------------------------------------------------------------------------------" , "import Control.Lens as X (_Left, _Right, iat, over, preview, sans, set, to)" , "import Control.Lens as X (view, (%~), (&), (.~), (?~), (^.), (^?))" , "import Control.Lens.Extras as X (is)" , "" , "--------------------------------------------------------------------------------" , "import Control.Applicative as X ((<|>))" , "import Control.Monad as X (guard, unless, when, (<=<), (>=>))" , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither)" , "import Control.Monad.Except as X (runExceptT, withExceptT)" , "import Control.Monad.IO.Unlift as X" , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" , "--------------------------------------------------------------------------------" ] ex16 :: Assertion ex16 = assertSnippet (step Nothing felixOptions) [ "module Foo where" , "" , "import B ()" , "import A ()" ] [ "module Foo where" , "" , "import A ()" , "import B ()" ] felixOptions :: Options felixOptions = defaultOptions { listAlign = Repeat } stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs0000644000000000000000000012110207346545000025157 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Imports.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- fromImportAlign :: ImportAlign -> Options fromImportAlign align = defaultOptions { 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 08b" case08b , testCase "case 09" case09 , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 11b" case11b , testCase "case 12" case12 , testCase "case 12b" case12b , testCase "case 13" case13 , testCase "case 13b" case13b , testCase "case 14" case14 , testCase "case 15" case15 , testCase "case 16" case16 , testCase "case 17" case17 , testCase "case 18" case18 , testCase "case 19" case19 , testCase "case 19b" case19b , testCase "case 19d" case19c , testCase "case 19d" case19d , testCase "case 20" case20 , testCase "case 21" case21 , testCase "case 22" case22 , testCase "case 23" case23 , testCase "case 23b" case23b , testCase "case 24" case24 , testCase "case 25" case25 , testCase "case 26 (issue #185)" case26 , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 , testCase "case 30" case30 , testCase "case 31" case31 , testCase "case 32" case32 , testCase "case 33" case33 , testCase "case 34" case34 , testCase "case 35" case35 , testCase "case 36" case36 , testCase "case 37" case37 , testCase "case 38" case38 , testCase "case 39" case39 , testCase "case 40" case40 , testCase "case 41" case41 , testCase "case 42" case42 , testCase "case 43" case43 , testCase "case 44a" case44a , testCase "case 44b" case44b , testCase "case 44c" case44c ] -------------------------------------------------------------------------------- input :: Snippet input = [ "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 = assertSnippet (step (Just 80) $ fromImportAlign Global) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse," , " tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case02 :: Assertion case02 = assertSnippet (step (Just 80) $ fromImportAlign Group) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init, last," , " length, map, null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = assertSnippet (step (Just 80) $ fromImportAlign None) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map," , " null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case04 :: Assertion case04 = assertSnippet (step (Just 80) $ fromImportAlign Global) [ "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" ] [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," , " object, parseEither, typeMismatch, (.!=)," , " (.:), (.:?), (.=))" ] -------------------------------------------------------------------------------- case05 :: Assertion case05 = assertSnippet (step (Just 80) $ fromImportAlign Group) input' input' where -- Putting this on a different line shouldn't really help. input' = ["import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)"] -------------------------------------------------------------------------------- case06 :: Assertion case06 = assertSnippet (step (Just 80) $ fromImportAlign File) input' input' where input' = [ "import Bar.Qux" , "import Foo.Bar" ] -------------------------------------------------------------------------------- case07 :: Assertion case07 = assertSnippet (step (Just 80) $ fromImportAlign File) [ "import Bar.Qux" , "" , "import qualified Foo.Bar" ] [ "import Bar.Qux" , "" , "import qualified Foo.Bar" ] -------------------------------------------------------------------------------- case08 :: Assertion case08 = let options = defaultOptions { listAlign = WithAlias } in assertSnippet (step (Just 80) options) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail," , " (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case08b :: Assertion case08b = let options = defaultOptions { listAlign = WithModuleName } in assertSnippet (step (Just 80) options) input ["module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case09 :: Assertion case09 = let options = defaultOptions { listAlign = WithAlias, longListAlign = Multiline } in assertSnippet (step (Just 80) options) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List" , " ( concat" , " , foldl" , " , foldr" , " , head" , " , init" , " , last" , " , length" , " , map" , " , null" , " , reverse" , " , tail" , " , (++)" , " )" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case10 :: Assertion case10 = let options = defaultOptions { importAlign = Group , listAlign = WithAlias , longListAlign = Multiline } in assertSnippet (step (Just 40) options) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List" , " ( concat" , " , foldl" , " , foldr" , " , head" , " , init" , " , last" , " , length" , " , map" , " , null" , " , reverse" , " , tail" , " , (++)" , " )" , "import Data.Map" , " ( Map" , " , insert" , " , lookup" , " , (!)" , " )" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case11 :: Assertion case11 = let options = defaultOptions { importAlign = Group, listAlign = NewLine } in assertSnippet (step (Just 80) options) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" , "import Data.Map" , " (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances" , " ()" , "" , "import Foo" , " (Bar (..))" , "import Herp.Derp.Internals hiding" , " (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] case11b :: Assertion case11b = let options = defaultOptions { importAlign = Group, listAlign = WithModuleName } in assertSnippet (step (Just 80) options) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init, last," , " length, map, null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case12 :: Assertion case12 = let options = defaultOptions { importAlign = Group , listAlign = NewLine , listPadding = LPConstant 2 } in assertSnippet (step (Just 80) options) [ "import Data.List (map)" ] [ "import Data.List" , " (map)" ] -------------------------------------------------------------------------------- case12b :: Assertion case12b = let options = defaultOptions { importAlign = Group , listAlign = WithModuleName , listPadding = LPConstant 2 } in assertSnippet (step (Just 80) options) ["import Data.List (map)"] ["import Data.List (map)"] -------------------------------------------------------------------------------- case13 :: Assertion case13 = let options = defaultOptions { importAlign = None , listAlign = WithAlias , longListAlign = InlineWithBreak } in assertSnippet (step (Just 80) options) [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" ] case13b :: Assertion case13b = let options = defaultOptions { importAlign = None , listAlign = WithModuleName , longListAlign = InlineWithBreak } in assertSnippet (step (Just 80) options) [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" ] -------------------------------------------------------------------------------- case14 :: Assertion case14 = let options = defaultOptions { importAlign = None , listAlign = WithAlias , longListAlign = InlineWithBreak , listPadding = LPConstant 10 } in assertSnippet (step (Just 80) options) [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" ] [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" ] -------------------------------------------------------------------------------- case15 :: Assertion case15 = let options = defaultOptions { importAlign = None, longListAlign = Multiline } in assertSnippet (step (Just 80) options) [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" ] [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid" , " ( closeAcidState" , " , createCheckpoint" , " , openLocalStateFrom" , " )" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" ] -------------------------------------------------------------------------------- case16 :: Assertion case16 = let options = defaultOptions { importAlign = None , longListAlign = Multiline , separateLists = False } in assertSnippet (step (Just 80) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" ] [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Maybe (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] -------------------------------------------------------------------------------- case17 :: Assertion case17 = let options = defaultOptions { importAlign = None, longListAlign = Multiline } in assertSnippet (step (Just 80) options) [ "import Control.Applicative (Applicative ((<*>),pure))" , "" , "import Data.Identity (Identity (runIdentity,Identity))" ] [ "import Control.Applicative (Applicative (pure, (<*>)))" , "" , "import Data.Identity (Identity (Identity, runIdentity))" ] -------------------------------------------------------------------------------- case18 :: Assertion case18 = let options = defaultOptions { importAlign = None, longListAlign = InlineToMultiline } in assertSnippet (step (Just 40) options) [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" , "import Data.Identity (Identity (Identity, runIdentity))" , "" , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" ] ---------------------------------------- [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" , "import Data.Identity" , " (Identity (Identity, runIdentity))" , "" , "import Data.Acid as Acid" , " ( closeAcidState" , " , createCheckpoint" , " , openLocalStateFrom" , " )" ] -------------------------------------------------------------------------------- case19 :: Assertion case19 = let options = defaultOptions { listAlign = NewLine , longListAlign = InlineWithBreak , emptyListAlign = RightAfter , listPadding = LPConstant 17 } in assertSnippet (step (Just 40) options) case19input ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" , " (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," , " intersperse)" ] case19b :: Assertion case19b = let options = defaultOptions { importAlign = File , listAlign = NewLine , longListAlign = InlineWithBreak , emptyListAlign = RightAfter , listPadding = LPConstant 17 } in assertSnippet (step (Just 40) options) case19input ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," , " intersperse)" ] case19c :: Assertion case19c = let options = defaultOptions { importAlign = File , listAlign = NewLine , longListAlign = InlineWithBreak , emptyListAlign = RightAfter , listPadding = LPModuleName } in assertSnippet (step (Just 40) options) case19input ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," , " intersperse)" ] case19d :: Assertion case19d = let options = defaultOptions { listAlign = NewLine , longListAlign = InlineWithBreak , emptyListAlign = RightAfter , listPadding = LPModuleName } in assertSnippet (step (Just 40) options) case19input ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" , " (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," , " intersperse)" ] case19input :: Snippet case19input = Snippet [ "import Prelude.Compat hiding (foldMap)" , "import Prelude ()" , "" , "import Data.List (foldl', intercalate, intersperse)" ] -------------------------------------------------------------------------------- case20 :: Assertion case20 = assertSnippet (step (Just 80) defaultOptions) [ "import {-# SOURCE #-} Data.ByteString as BS" , "import {-# SOURCE #-} qualified Data.Text as T" , "import qualified Data.Map as Map" , "import Data.Set (empty)" ] [ "import {-# SOURCE #-} Data.ByteString as BS" , "import qualified Data.Map as Map" , "import Data.Set (empty)" , "import {-# SOURCE #-} qualified Data.Text as T" ] -------------------------------------------------------------------------------- case21 :: Assertion case21 = assertSnippet (step (Just 80) defaultOptions) [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, A, C, A, B, A)" , "import X2 (C(), B(), A())" , "import X3 (A(..))" , "import X4 (A, A(..))" , "import X5 (A(..), A(x))" , "import X6 (A(a,b), B(m,n), A(c), B(o))" , "import X7 (a, b, a, c)" , "import X8 (type (+), (+))" , "import X9 hiding (x, y, z, x)" ] [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, C)" , "import X2 (A, B, C)" , "import X3 (A (..))" , "import X4 (A (..))" , "import X5 (A (..))" , "import X6 (A (a, b, c), B (m, n, o))" , "import X7 (a, b, c)" , "import X8 (type (+), (+))" , "import X9 hiding (x, y, z)" ] -------------------------------------------------------------------------------- case22 :: Assertion case22 = assertSnippet (step (Just 80) defaultOptions) [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"foo\" A" , "import \"blah\" A" , "import qualified \"foo\" A as X" -- this import fits into 80 chats without "foo", -- but doesn't fit when "foo" is included into the calculation , "import \"foo\" B (someLongName, someLongerName, " ++ "theLongestNameYet, shortName)" ] [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"blah\" A" , "import \"foo\" A" , "import qualified \"foo\" A as X" , "import \"foo\" B (shortName, someLongName, someLongerName," , " theLongestNameYet)" ] -------------------------------------------------------------------------------- case23 :: Assertion case23 = let options = defaultOptions { importAlign = None , padModuleNames = False , spaceSurround = True } in assertSnippet (step (Just 40) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Monoid ((<>) )" , "" , "import Data.ALongName.Foo (Foo, Goo, Boo)" ] ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class ( Default (def) )" , "" , "import Data.Monoid ( (<>) )" , "" , "import Data.ALongName.Foo ( Boo, Foo," , " Goo )" ] -------------------------------------------------------------------------------- case23b :: Assertion case23b = let options = defaultOptions { importAlign = None , listAlign = WithModuleName , padModuleNames = False , spaceSurround = True } in assertSnippet (step (Just 40) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Monoid ((<>) )" , "" , "import Data.ALongName.Foo (Foo, Goo, Boo)" ] ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" , "" , "import Data.Monoid ( (<>) )" , "" , "import Data.ALongName.Foo ( Boo, Foo," , " Goo )" ] -------------------------------------------------------------------------------- case24 :: Assertion case24 = let options = defaultOptions { importAlign = None , padModuleNames = False , longListAlign = InlineWithBreak , spaceSurround = True } in assertSnippet (step (Just 40) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.ALongName.Foo (FooReallyLong, " ++ "GooReallyLong, BooReallyLong)" ] ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" , "" , "import Data.ALongName.Foo" , " ( BooReallyLong, FooReallyLong," , " GooReallyLong )" ] -------------------------------------------------------------------------------- case25 :: Assertion case25 = let options = defaultOptions { importAlign = Group , padModuleNames = False , longListAlign = Multiline , separateLists = False } in assertSnippet (step (Just 80) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" ] [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" , "import Data.Maybe (Maybe(Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] -------------------------------------------------------------------------------- case26 :: Assertion case26 = assertSnippet (step (Just 80) options) ["import Data.List"] ["import Data.List"] where options = defaultOptions { listAlign = NewLine, longListAlign = Multiline } -------------------------------------------------------------------------------- case27 :: Assertion case27 = assertSnippet (step Nothing $ fromImportAlign Global) input [ "module Herp where" , "" , "import Control.Monad" , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" , "" , "import Foo (Bar (..))" , "import Herp.Derp.Internals hiding (foo)" , "" , "herp = putStrLn \"import Hello world\"" ] -------------------------------------------------------------------------------- case28 :: Assertion case28 = assertSnippet (step (Just 80) $ fromImportAlign Global) [ "import Data.Default.Class (Default(def))" , "import qualified Data.Aeson as JSON" , "import qualified Data.Aeson as JSON" , "import Control.Monad" , "import Control.Monad" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" , "import Data.Foo (Foo (Foo,Bar))" , "import Data.Set (empty, intersect)" , "import Data.Set (empty, nub)" ] [ "import Control.Monad" , "import qualified Data.Aeson as JSON" , "import Data.Default.Class (Default (def))" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe (Just, Nothing))" , "" , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" , "import Data.Set (empty, intersect, nub)" ] -------------------------------------------------------------------------------- case29 :: Assertion case29 = assertSnippet (step Nothing $ fromImportAlign Group) -- Check that "Group" mode recognizes groups with multi-line imports [ "import Foo (foo)" , "import BarBar ( bar" , " , kek)" , "import Abcd ()" , "" , "import A (A)" ] [ "import Abcd ()" , "import BarBar (bar, kek)" , "import Foo (foo)" , "" , "import A (A)" ] -------------------------------------------------------------------------------- case30 :: Assertion case30 = assertSnippet (step Nothing defaultOptions {separateLists = False}) ["import Data.Monoid (Monoid (..))"] ["import Data.Monoid (Monoid(..))"] -------------------------------------------------------------------------------- case31 :: Assertion case31 = assertSnippet (step Nothing defaultOptions {postQualified = True}) ["import Data.Monoid (Monoid (..))"] ["import Data.Monoid (Monoid (..))"] -------------------------------------------------------------------------------- case32 :: Assertion case32 = assertSnippet (step Nothing defaultOptions {postQualified = True}) ["import qualified Data.Monoid as M"] ["import Data.Monoid qualified as M"] -------------------------------------------------------------------------------- case33 :: Assertion case33 = assertSnippet (step Nothing defaultOptions {postQualified = True}) [ "import Data.Default.Class (Default(def))" , "import qualified Data.Aeson as JSON" , "import qualified Data.Aeson as JSON" , "import Control.Monad" , "import Control.Monad" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" , "import Data.Foo (Foo (Foo,Bar))" , "import Data.Set (empty, intersect)" , "import Data.Set (empty, nub)" ] [ "import Control.Monad" , "import Data.Aeson qualified as JSON" , "import Data.Default.Class (Default (def))" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import Data.Maybe.Extra qualified (Maybe (Just, Nothing))" , "" , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" , "import Data.Set (empty, intersect, nub)" ] -------------------------------------------------------------------------------- case34 :: Assertion case34 = assertSnippet (step Nothing defaultOptions {postQualified = True}) [ "import qualified Data.Aeson as JSON (Value)" ] [ "import Data.Aeson qualified as JSON (Value)" ] -------------------------------------------------------------------------------- case35 :: Assertion case35 = assertSnippet (step Nothing defaultOptions {postQualified = True}) [ "import Data.Aeson qualified as JSON (Value)" ] [ "import Data.Aeson qualified as JSON (Value)" ] -------------------------------------------------------------------------------- case36 :: Assertion case36 = assertSnippet (step Nothing defaultOptions {postQualified = True}) [ "import qualified Data.Aeson as JSON (Value)" , "import qualified Data.Aeson as JSON (encode, decode)" ] [ "import Data.Aeson qualified as JSON (Value, decode, encode)" ] -------------------------------------------------------------------------------- case37 :: Assertion case37 = assertSnippet (step Nothing defaultOptions {postQualified = True}) [ "import Data.Aeson qualified as JSON (Value)" , "import Data.Aeson qualified as JSON (encode, decode)" ] [ "import Data.Aeson qualified as JSON (Value, decode, encode)" ] -------------------------------------------------------------------------------- case38 :: Assertion case38 = assertSnippet (step (Just 80) $ fromImportAlign File) [ "import HSP" , "import Happstack.Server" ] [ "import Happstack.Server" , "import HSP" ] -------------------------------------------------------------------------------- case39 :: Assertion case39 = assertSnippet (step Nothing options) [ "import Something.A" , "import SomethingElse.A" , "import SomeThing.B" , "import SomeThingelse.B" ] [ "import SomeThing.B" , "" , "import SomeThingelse.B" , "" , "import Something.A" , "" , "import SomethingElse.A" ] where options = defaultOptions { groupImports = True } -------------------------------------------------------------------------------- case40 :: Assertion case40 = assertSnippet (step Nothing options) [ "import Data.Default.Class (Default(def))" , "import qualified Data.Aeson as JSON" , "import qualified Data.Aeson as JSON" , "import Control.Monad" , "import Control.Monad" , "" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" , "import Data.Foo (Foo (Foo,Bar))" , "import Data.Set (empty, intersect)" , "import Data.Set (empty, nub)" ] [ "import Control.Monad" , "" , "import Data.Aeson qualified as JSON" , "import Data.Default.Class (Default (def))" , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" , "import Data.Maybe (Maybe (Just, Nothing))" , "import Data.Maybe.Extra qualified (Maybe (Just, Nothing))" , "import Data.Set (empty, intersect, nub)" ] where options = defaultOptions { groupImports = True, postQualified = True } -------------------------------------------------------------------------------- case41 :: Assertion case41 = assertSnippet (step Nothing options) [ "import Data.Default.Class (Default(def))" , "import qualified Data.Aeson as JSON" , "import Control.Monad" , "import Control.Monad" , "import qualified Foo.Bar.Baz" , "" , "import Data.Set (empty, intersect)" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe(Just, Nothing))" , "" , "import qualified Data.Aeson as JSON" , "" , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" , "import Data.Foo (Foo (Foo,Bar))" , "import Data.Set (empty, nub)" , "import Foo.Bar.Baz (Foo)" ] [ "import Control.Monad" , "" , "import qualified Data.Aeson as JSON" , "import Data.Default.Class (Default (def))" , "import Data.Foo (Foo (Bar, Foo), Goo (Goo))" , "import Data.Maybe (Maybe (Just, Nothing))" , "import qualified Data.Maybe.Extra (Maybe (Just, Nothing))" , "import Data.Set (empty, intersect, nub)" , "" , "import Foo.Bar.Baz (Foo)" , "import qualified Foo.Bar.Baz" ] where options = defaultOptions { groupImports = True, importAlign = Group } -------------------------------------------------------------------------------- case42 :: Assertion case42 = assertSnippet (step (Just 80) options) [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default (def))" , "import Control.Monad" , "" , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" ] [ "import Control.Monad" , "" , "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)" ] where options = defaultOptions { groupImports = True , importAlign = None , longListAlign = Multiline } -------------------------------------------------------------------------------- case43 :: Assertion case43 = assertSnippet (step (Just 80) options) [ "import Project.Internal.Blah" , "import Project.Something" , "import Control.Monad" , "" , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" , "" , "import qualified Project.Internal.Blarg as Blarg" , "import Control.Applicative" , "import Data.Functor" , "import Data.Acid (AcidState)" , "import Project" , "" , "import Data.Map (Map)" , "import qualified Data.Map as Map" ] [ "import Project.Internal.Blah" , "import qualified Project.Internal.Blarg as Blarg" , "" , "import Project" , "import Project.Something" , "" , "import Control.Applicative" , "import Control.Monad" , "" , "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid" , " ( closeAcidState" , " , createCheckpoint" , " , openLocalStateFrom" , " )" , "import Data.Functor" , "import Data.Map (Map)" , "import qualified Data.Map as Map" ] where options = defaultOptions { groupImports = True , groupRules = [ GroupRule { match = unsafeParsePattern "Project\\.Internal" , subGroup = Nothing } , GroupRule { match = unsafeParsePattern "Project" , subGroup = Nothing } , GroupRule { match = unsafeParsePattern ".*" , subGroup = Just $ unsafeParsePattern "^[^.]+" } ] , importAlign = None , longListAlign = Multiline } -------------------------------------------------------------------------------- case44a :: Assertion case44a = assertSnippet (step (Just 80) options) [ "import Project" , "import Control.Monad" , "" , "import qualified Data.Acid as Acid" , "import Project.Something" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" , "import ProJect.WrongCapitalization" ] [ "import Project" , "import Project.Something" , "" , "import Control.Monad" , "import qualified Data.Acid as Acid" , "import Data.Default.Class (Default (def))" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" , "import ProJect.WrongCapitalization" ] where options = defaultOptions { groupImports = True , groupRules = [ GroupRule { match = unsafeParsePattern "Project" , subGroup = Nothing } ] , importAlign = None } -------------------------------------------------------------------------------- case44b :: Assertion case44b = assertSnippet (step (Just 80) options) [ "import Project" , "import Control.Monad" , "" , "import qualified Data.Acid as Acid" , "import Project.Something" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" , "import ProJect.WrongCapitalization" ] [ "import Project" , "import Project.Something" , "" , "import qualified Data.Acid as Acid" , "" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" , "" , "import Control.Monad" , "" , "import ProJect.WrongCapitalization" ] where options = defaultOptions { groupImports = True , groupRules = [ GroupRule { match = unsafeParsePattern "Project" , subGroup = Nothing } , GroupRule { match = unsafeParsePattern "[^.]+\\.[^.]+" , subGroup = Just $ unsafeParsePattern "\\.[^.]+" } ] , importAlign = None } -------------------------------------------------------------------------------- case44c :: Assertion case44c = assertSnippet (step (Just 80) options) [ "import Project" , "import Control.Monad" , "" , "import qualified Data.Acid as Acid" , "import Project.Something" , "import Data.Default.Class (Default (def))" , "" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" , "import ProJect.WrongCapitalization" ] [ "import Project" , "import Project.Something" , "" , "import Control.Monad" , "import qualified Data.Acid as Acid" , "import Data.Default.Class (Default (def))" , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" , "import ProJect.WrongCapitalization" ] where options = defaultOptions { groupImports = True , groupRules = [ GroupRule { match = unsafeParsePattern "Project" , subGroup = Nothing } , GroupRule { match = unsafeParsePattern "[^.]+\\.[^.]+" , subGroup = Nothing } ] , importAlign = None } stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/LanguagePragmas/0000755000000000000000000000000007346545000025125 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs0000644000000000000000000001753507346545000026576 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} 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 , testCase "case 09" case09 , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 , testCase "case 13" case13 , testCase "case 14" case14 ] lANG :: String lANG = "LANGUAGE" -------------------------------------------------------------------------------- case01 :: Assertion case01 = assertSnippet (step (Just 80) Vertical True False lANG) [ "{-# LANGUAGE ViewPatterns #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" , "{-# LANGUAGE ScopedTypeVariables #-}" , "module Main where" ] [ "{-# LANGUAGE ScopedTypeVariables #-}" , "{-# LANGUAGE TemplateHaskell #-}" , "{-# LANGUAGE ViewPatterns #-}" , "module Main where" ] -------------------------------------------------------------------------------- case02 :: Assertion case02 = assertSnippet (step (Just 80) Vertical True True lANG) [ "{-# LANGUAGE BangPatterns #-}" , "{-# LANGUAGE ViewPatterns #-}" , "module Main where" , "increment ((+ 1) -> x) = x" ] [ "{-# LANGUAGE ViewPatterns #-}" , "module Main where" , "increment ((+ 1) -> x) = x" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = assertSnippet (step (Just 80) Vertical True True lANG) [ "{-# LANGUAGE BangPatterns #-}" , "{-# LANGUAGE ViewPatterns #-}" , "module Main where" , "increment x = case x of !_ -> x + 1" ] [ "{-# LANGUAGE BangPatterns #-}" , "module Main where" , "increment x = case x of !_ -> x + 1" ] -------------------------------------------------------------------------------- case04 :: Assertion case04 = assertSnippet (step (Just 80) Compact True False lANG) [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," , " TemplateHaskell #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" ] [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ "TemplateHaskell," , " TypeOperators, ViewPatterns #-}" ] -------------------------------------------------------------------------------- case05 :: Assertion case05 = assertSnippet (step (Just 80) Vertical True False lANG) [ "{-# LANGUAGE CPP #-}" , "" , "#if __GLASGOW_HASKELL__ >= 702" , "{-# LANGUAGE Trustworthy #-}" , "#endif" ] [ "{-# LANGUAGE CPP #-}" , "" , "#if __GLASGOW_HASKELL__ >= 702" , "{-# LANGUAGE Trustworthy #-}" , "#endif" ] -------------------------------------------------------------------------------- case06 :: Assertion case06 = assertSnippet (step (Just 80) CompactLine True False lANG) [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," , " TemplateHaskell #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" ] [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ "TemplateHaskell #-}" , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" ] -------------------------------------------------------------------------------- case07 :: Assertion case07 = assertSnippet (step (Just 80) Vertical False False lANG) [ "{-# LANGUAGE ViewPatterns #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" , "module Main where" ] [ "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE ScopedTypeVariables #-}" , "{-# LANGUAGE TemplateHaskell #-}" , "{-# LANGUAGE ViewPatterns #-}" , "module Main where" ] -------------------------------------------------------------------------------- case08 :: Assertion case08 = assertSnippet (step (Just 80) CompactLine False False lANG) [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," , " TemplateHaskell #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" ] [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ "TemplateHaskell #-}" , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" ] -------------------------------------------------------------------------------- case09 :: Assertion case09 = assertSnippet (step (Just 80) Compact True False lANG) [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ "TypeApplications" , " #-}" ] [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," , " TypeApplications #-}" ] -------------------------------------------------------------------------------- case10 :: Assertion case10 = assertSnippet (step (Just 80) Compact True False lANG) [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," , " TypeApplications #-}" ] [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ "TypeApplications #-}" ] -------------------------------------------------------------------------------- case11 :: Assertion case11 = assertSnippet (step (Just 80) Vertical False False "language") [ "{-# LANGUAGE ViewPatterns #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" , "module Main where" ] [ "{-# language NoImplicitPrelude #-}" , "{-# language ScopedTypeVariables #-}" , "{-# language TemplateHaskell #-}" , "{-# language ViewPatterns #-}" , "module Main where" ] -------------------------------------------------------------------------------- case12 :: Assertion case12 = assertSnippet (step Nothing Compact False False "language") [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" , "module Main where" ] [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" , "module Main where" ] -------------------------------------------------------------------------------- case13 :: Assertion case13 = assertSnippet (step Nothing Vertical True True lANG) input input where input = [ "{-# LANGUAGE BangPatterns #-}" , "{-# LANGUAGE DeriveFunctor #-}" , "" , "main = let !x = 1 + 1 in print x" ] -------------------------------------------------------------------------------- case14 :: Assertion case14 = assertSnippet (step Nothing VerticalCompact False False "language") [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" , "module Main where" ] [ "{-# language" , " NoImplicitPrelude" , " , OverloadedStrings" , " , ScopedTypeVariables" , " , TemplateHaskell" , " , ViewPatterns" , " #-}" , "module Main where" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/ModuleHeader/0000755000000000000000000000000007346545000024425 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs0000644000000000000000000005606207346545000026074 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.ModuleHeader.Tests ( tests ) where -------------------------------------------------------------------------------- import Prelude hiding (lines) import Data.Function((&)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.ModuleHeader import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" [ testCase "Does not indent absent export list" ex0 , testCase "Does not indent absent export list, open_bracket = same_line" ex0a , testCase "Empty exports list" ex1 , testCase "Empty exports list , open_bracket = same_line" ex1a , testCase "Single exported variable" ex2 , testCase "Single exported variable, open_bracket = same_line" ex2a , testCase "Multiple exported variables" ex3 , testCase "Multiple exported variables, open_bracket = same_line" ex3a , testCase "Only reformats module header" ex4 , testCase "Only reformats module header, open_bracket = same_line" ex4a , testCase "Leaving pragmas in place" ex5 , testCase "Leaving pragmas in place, open_bracket = same_line" ex5a , testCase "Leaving pragmas in place variant" ex6 , testCase "Leaving pragmas in place variant, open_bracket = same_line" ex6a , testCase "Leaving comments in place" ex7 , testCase "Leaving comments in place, open_bracket = same_line" ex7a , testCase "Exports all" ex8 , testCase "Exports all, open_bracket = same_line" ex8a , testCase "Exports module" ex9 , testCase "Exports module, open_bracket = same_line" ex9a , testCase "Exports symbol" ex10 , testCase "Exports symbol, open_bracket = same_line" ex10a , testCase "Respects groups" ex11 , testCase "Respects groups, open_bracket = same_line" ex11a , testCase "'where' not repeated when not part of exports with always break_where" ex12 , testCase "'where' not repeated when not part of exports with always break_where, open_bracket = same_line" ex12a , testCase "Indents absent export list with 2 spaces with always break_where" ex13 , testCase "Indents absent export list with 2 spaces with always break_where, open_bracket = same_line" ex13a , testCase "Indents with 2 spaces" ex14 , testCase "Indents with 2 spaces, open_bracket = same_line" ex14a , testCase "Group doc with 2 spaces" ex15 , testCase "Group doc with 2 spaces, open_bracket = same_line" ex15a , testCase "Does not sort" ex16 , testCase "Repects separate_lists" ex17 , testCase "Repects separate_lists, open_bracket = same_line" ex17a , testCase "Indents absent export list with always break_where" ex18 , testCase "Respects bundled patterns" ex19 , testCase "Respects bundled patterns, open_bracket = same_line" ex19a , testCase "Inline no export list" ex20 , testCase "Inline empty export list" ex21 , testCase "Inline empty export list, open_bracket = same_line" ex21a , testCase "Inline single export" ex22 , testCase "Inline single export, open_bracket = same_line" ex22a , testCase "Inline single line sorts" ex23 , testCase "Inline single line sorts, open_bracket = same_line" ex23a , testCase "Inline breaks when too long" ex24 , testCase "Inline breaks when too long, open_bracket = same_line" ex24a , testCase "Inline single line when no max cols" ex25 , testCase "Inline single line when no max cols, open_bracket = same_line" ex25a , testCase "Inline breaks when comments present" ex26 , testCase "Inline breaks when comments present, open_bracket = same_line" ex26a , testCase "Single no export list" ex27 , testCase "Single no export list, open_bracket = same_line" ex27a , testCase "Single empty export list" ex28 , testCase "Single empty export list, open_bracket = same_line" ex28a , testCase "Single one export" ex29 , testCase "Single one export, open_bracket = same_line" ex29a , testCase "Single two exports" ex30 , testCase "Single two exports, open_bracket = same_line" ex30a , testCase "Single one export with comment" ex31 , testCase "Single one export with comment, open_bracket = same_line" ex31a , testCase "Single one module comment" ex32 , testCase "Inline comments" ex33 , testCase "Deprecated pragma to the module" ex34 , testCase "Warning pragma without export list" ex35 ] -------------------------------------------------------------------------------- ex0 :: Assertion ex0 = assertSnippet (step Nothing defaultConfig) input input where input = [ "module Foo where" ] ex0a :: Assertion ex0a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) input input where input = [ "module Foo where" ] ex1 :: Assertion ex1 = assertSnippet (step Nothing defaultConfig) [ "module Foo () where" ] [ "module Foo" , " (" , " ) where" ] ex1a :: Assertion ex1a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo () where" ] [ "module Foo (" , " " , " ) where" ] ex2 :: Assertion ex2 = assertSnippet (step Nothing defaultConfig) [ "module Foo (tests) where" ] [ "module Foo" , " ( tests" , " ) where" ] ex2a :: Assertion ex2a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (tests) where" ] [ "module Foo (" , " tests" , " ) where" ] ex3 :: Assertion ex3 = assertSnippet (step Nothing defaultConfig) [ "module Foo (t1, t2, t3) where" ] [ "module Foo" , " ( t1" , " , t2" , " , t3" , " ) where" ] ex3a :: Assertion ex3a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (t1, t2, t3) where" ] [ "module Foo (" , " t1" , " , t2" , " , t3" , " ) where" ] ex4 :: Assertion ex4 = assertSnippet (step Nothing defaultConfig) [ "module Foo (" , " t1," , " t3," , " t2" , ") where" , "" , "" , "-- | Docstring" , "foo :: Int" , "foo = 1" ] [ "module Foo" , " ( t1" , " , t2" , " , t3" , " ) where" , "" , "" , "-- | Docstring" , "foo :: Int" , "foo = 1" ] ex4a :: Assertion ex4a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (" , " t1," , " t3," , " t2" , ") where" , "" , "" , "-- | Docstring" , "foo :: Int" , "foo = 1" ] [ "module Foo (" , " t1" , " , t2" , " , t3" , " ) where" , "" , "" , "-- | Docstring" , "foo :: Int" , "foo = 1" ] ex5 :: Assertion ex5 = assertSnippet (step Nothing defaultConfig) [ "{-# LANGUAGE DerivingVia #-}" , "-- | This module docs" , "module Foo (" , " t1," , " t3," , " t2" , ") where" ] [ "{-# LANGUAGE DerivingVia #-}" , "-- | This module docs" , "module Foo" , " ( t1" , " , t2" , " , t3" , " ) where" ] ex5a :: Assertion ex5a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "{-# LANGUAGE DerivingVia #-}" , "-- | This module docs" , "module Foo (" , " t1," , " t3," , " t2" , ") where" ] [ "{-# LANGUAGE DerivingVia #-}" , "-- | This module docs" , "module Foo (" , " t1" , " , t2" , " , t3" , " ) where" ] ex6 :: Assertion ex6 = assertSnippet (step Nothing defaultConfig) [ "-- | This module docs" , "{-# LANGUAGE DerivingVia #-}" , "module Foo (" , " t1," , " t3," , " t2" , ") where" ] [ "-- | This module docs" , "{-# LANGUAGE DerivingVia #-}" , "module Foo" , " ( t1" , " , t2" , " , t3" , " ) where" ] ex6a :: Assertion ex6a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "-- | This module docs" , "{-# LANGUAGE DerivingVia #-}" , "module Foo (" , " t1," , " t3," , " t2" , ") where" ] [ "-- | This module docs" , "{-# LANGUAGE DerivingVia #-}" , "module Foo (" , " t1" , " , t2" , " , t3" , " ) where" ] ex7 :: Assertion ex7 = assertSnippet (step Nothing defaultConfig) [ "module Foo -- Foo" , "(" , " -- * t1 something" , " t3," , " t1," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo -- Foo" , " ( -- * t1 something" , " t1" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex7a :: Assertion ex7a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo -- Foo" , "(" , " -- * t1 something" , " t3," , " t1," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo ( -- Foo" , " -- * t1 something" , " t1" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex8 :: Assertion ex8 = assertSnippet (step Nothing defaultConfig) [ "module Foo (" , " -- * t1 something" , " t3," , " A(..)," , " -- * t2 something" , " t2," , " t1" , ") where -- x" , "-- y" ] [ "module Foo" , " ( -- * t1 something" , " A (..)" , " , t3" , " -- * t2 something" , " , t1" , " , t2" , " ) where -- x" , "-- y" ] ex8a :: Assertion ex8a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (" , " -- * t1 something" , " t3," , " A(..)," , " -- * t2 something" , " t2," , " t1" , ") where -- x" , "-- y" ] [ "module Foo (" , " -- * t1 something" , " A (..)" , " , t3" , " -- * t2 something" , " , t1" , " , t2" , " ) where -- x" , "-- y" ] ex9 :: Assertion ex9 = assertSnippet (step Nothing defaultConfig) [ "module Foo (" , " -- * t1 something" , " module A," , " t3," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo" , " ( -- * t1 something" , " module A" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex9a :: Assertion ex9a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (" , " -- * t1 something" , " module A," , " t3," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo (" , " -- * t1 something" , " module A" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex10 :: Assertion ex10 = assertSnippet (step Nothing defaultConfig) [ "module Foo (" , " (<&>)" , ") where -- x" , "-- y" ] [ "module Foo" , " ( (<&>)" , " ) where -- x" , "-- y" ] ex10a :: Assertion ex10a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (" , " (<&>)" , ") where -- x" , "-- y" ] [ "module Foo (" , " (<&>)" , " ) where -- x" , "-- y" ] ex11 :: Assertion ex11 = assertSnippet (step Nothing defaultConfig) [ "module Foo (" , " -- group 1" , " g1_1," , " g1_0," , " -- group 2" , " g0_1," , " g0_0" , ") where" ] [ "module Foo" , " ( -- group 1" , " g1_0" , " , g1_1" , " -- group 2" , " , g0_0" , " , g0_1" , " ) where" ] ex11a :: Assertion ex11a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "module Foo (" , " -- group 1" , " g1_1," , " g1_0," , " -- group 2" , " g0_1," , " g0_0" , ") where" ] [ "module Foo (" , " -- group 1" , " g1_0" , " , g1_1" , " -- group 2" , " , g0_0" , " , g0_1" , " ) where" ] ex12 :: Assertion ex12 = assertSnippet (step Nothing defaultConfig {breakWhere = Always}) [ "module Foo" , " where" , "-- hmm" ] [ "module Foo" , " where" , "-- hmm" ] ex12a :: Assertion ex12a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Always} & openBracketSameLine) [ "module Foo" , " where" , "-- hmm" ] [ "module Foo" , " where" , "-- hmm" ] ex13 :: Assertion ex13 = assertSnippet (step Nothing defaultConfig {breakWhere = Always, indent = 2}) [ "module Foo where" ] [ "module Foo" , " where" ] ex13a :: Assertion ex13a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Always, indent = 2} & openBracketSameLine) [ "module Foo where" ] [ "module Foo" , " where" ] ex14 :: Assertion ex14 = assertSnippet (step Nothing defaultConfig {indent = 2}) [ "module Foo" , " ( yes" , " , no" , " ) where" ] [ "module Foo" , " ( no" , " , yes" , " ) where" ] ex14a :: Assertion ex14a = assertSnippet (step Nothing $ defaultConfig {indent = 2} & openBracketSameLine) [ "module Foo" , " ( yes" , " , no" , " ) where" ] [ "module Foo (" , " no" , " , yes" , " ) where" ] ex15 :: Assertion ex15 = assertSnippet (step Nothing defaultConfig {indent = 2}) [ "module Foo -- Foo" , "(" , " -- * t1 something" , " t3," , " t1," , " -- * t2 something" , " t2" , ") where" ] [ "module Foo -- Foo" , " ( -- * t1 something" , " t1" , " , t3" , " -- * t2 something" , " , t2" , " ) where" ] ex15a :: Assertion ex15a = assertSnippet (step Nothing $ defaultConfig {indent = 2} & openBracketSameLine) [ "module Foo -- Foo" , "(" , " -- * t1 something" , " t3," , " t1," , " -- * t2 something" , " t2" , ") where" ] [ "module Foo ( -- Foo" , " -- * t1 something" , " t1" , " , t3" , " -- * t2 something" , " , t2" , " ) where" ] ex16 :: Assertion ex16 = assertSnippet (step Nothing defaultConfig {sort = False}) input input where input = [ "module Foo" , " ( yes" , " , no" , " ) where" ] ex17 :: Assertion ex17 = assertSnippet (step Nothing defaultConfig {separateLists = False}) [ "module Foo" , " ( Bar (..)" , " ) where" ] [ "module Foo" , " ( Bar(..)" , " ) where" ] ex17a :: Assertion ex17a = assertSnippet (step Nothing $ defaultConfig {separateLists = False} & openBracketSameLine) [ "module Foo" , " ( Bar (..)" , " ) where" ] [ "module Foo (" , " Bar(..)" , " ) where" ] ex18 :: Assertion ex18 = assertSnippet (step Nothing defaultConfig {breakWhere = Always}) [ "module Foo where" ] [ "module Foo" , " where" ] ex19 :: Assertion ex19 = assertSnippet (step Nothing defaultConfig) [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo (Bar (.., Baz)) where" ] [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo" , " ( Bar (.., Baz)" , " ) where" ] ex19a :: Assertion ex19a = assertSnippet (step Nothing $ defaultConfig & openBracketSameLine) [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo (Bar (.., Baz)) where" ] [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo (" , " Bar (.., Baz)" , " ) where" ] ex20 :: Assertion ex20 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "module Foo where" ] [ "module Foo where" ] ex21 :: Assertion ex21 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "module Foo () where" ] [ "module Foo () where" ] ex21a :: Assertion ex21a = assertSnippet (step (Just 80) $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "module Foo () where" ] [ "module Foo () where" ] ex22 :: Assertion ex22 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "module Foo" , " ( main" , " ) where" ] [ "module Foo (main) where" ] ex22a :: Assertion ex22a = assertSnippet (step (Just 80) $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "module Foo" , " ( main" , " ) where" ] [ "module Foo (main) where" ] ex23 :: Assertion ex23 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo" , " ( Foo(MkFoo)" , " , Bar (.., Baz)" , " ) where" ] [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo (Bar (.., Baz), Foo (MkFoo)) where" ] ex23a :: Assertion ex23a = assertSnippet (step (Just 80) $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo" , " ( Foo(MkFoo)" , " , Bar (.., Baz)" , " ) where" ] [ "{-# LANGUAGE PatternSynonyms #-}" , "module Foo (Bar (.., Baz), Foo (MkFoo)) where" ] ex24 :: Assertion ex24 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] [ "module LongModuleName" , " ( longExportName1" , " , longExportName2" , " , longExportName3" , " , longExportName4" , " ) where" ] ex24a :: Assertion ex24a = assertSnippet (step (Just 80) $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] [ "module LongModuleName (" , " longExportName1" , " , longExportName2" , " , longExportName3" , " , longExportName4" , " ) where" ] ex25 :: Assertion ex25 = assertSnippet (step Nothing defaultConfig {breakWhere = Inline}) [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] ex25a :: Assertion ex25a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] [ "module LongModuleName (longExportName1, longExportName2, longExportName3, longExportName4) where" ] ex26 :: Assertion ex26 = assertSnippet (step (Just 80) defaultConfig {breakWhere = Inline}) [ "module Foo (" , " -- * t1 something" , " module A," , " t3," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo" , " ( -- * t1 something" , " module A" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex26a :: Assertion ex26a = assertSnippet (step (Just 80) $ defaultConfig {breakWhere = Inline} & openBracketSameLine) [ "module Foo (" , " -- * t1 something" , " module A," , " t3," , " -- * t2 something" , " t2" , ") where -- x" , "-- y" ] [ "module Foo (" , " -- * t1 something" , " module A" , " , t3" , " -- * t2 something" , " , t2" , " ) where -- x" , "-- y" ] ex27 :: Assertion ex27 = assertSnippet (step Nothing defaultConfig {breakWhere = Single}) [ "module Foo where" ] [ "module Foo where" ] ex27a :: Assertion ex27a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & openBracketSameLine) [ "module Foo where" ] [ "module Foo where" ] ex28 :: Assertion ex28 = assertSnippet (step Nothing defaultConfig {breakWhere = Single}) [ "module Foo () where" ] [ "module Foo () where" ] ex28a :: Assertion ex28a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & openBracketSameLine) [ "module Foo () where" ] [ "module Foo () where" ] ex29 :: Assertion ex29 = assertSnippet (step Nothing defaultConfig {breakWhere = Single}) [ "module Foo" , " ( main" , " ) where" ] [ "module Foo (main) where" ] ex29a :: Assertion ex29a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & openBracketSameLine) [ "module Foo" , " ( main" , " ) where" ] [ "module Foo (main) where" ] ex30 :: Assertion ex30 = assertSnippet (step Nothing defaultConfig {breakWhere = Single}) [ "module Foo" , " ( bar" , " , foo" , " ) where" ] [ "module Foo" , " ( bar" , " , foo" , " ) where" ] ex30a :: Assertion ex30a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & openBracketSameLine) [ "module Foo" , " ( bar" , " , foo" , " ) where" ] [ "module Foo (" , " bar" , " , foo" , " ) where" ] ex31 :: Assertion ex31 = assertSnippet (step Nothing defaultConfig {breakWhere = Single}) [ "module Foo" , " ( -- * Foo" , " Foo" , " ) where" ] [ "module Foo" , " ( -- * Foo" , " Foo" , " ) where" ] ex31a :: Assertion ex31a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & openBracketSameLine) [ "module Foo" , " ( -- * Foo" , " Foo" , " ) where" ] [ "module Foo (" , " -- * Foo" , " Foo" , " ) where" ] ex32 :: Assertion ex32 = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single}) [ "module Foo (bar) where -- Foo" ] [ "module Foo (bar) where -- Foo" ] ex33 :: Assertion ex33 = assertSnippet (step Nothing $ defaultConfig) [ "module Foo (" , " -- Bar" , " bar, -- Inline bar" , " -- Foo" , " foo -- Inline foo" , ") where" ] [ "module Foo" , " ( -- Bar" , " bar -- Inline bar" , " -- Foo" -- NOTE(jaspervdj): I would prefer to have the `,` here , " , foo -- Inline foo" , " ) where" ] ex34 :: Assertion ex34 = assertSnippet (step Nothing defaultConfig) [ "module X {-# DEPRECATED \"Do not use this\" #-}" , " (foo) where" ] [ "module X {-# DEPRECATED \"Do not use this\" #-}" , " ( foo" , " ) where" ] ex35 :: Assertion ex35 = assertSnippet (step Nothing defaultConfig) inp inp where inp = [ "module X {-# WARNING \"don't use it\" #-} where" , "" , "foo :: Int -> Int" , "foo = undefined" ] openBracketSameLine :: Config -> Config openBracketSameLine cfg = cfg { openBracket = SameLine } stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/SimpleAlign/0000755000000000000000000000000007346545000024273 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs0000644000000000000000000002057307346545000025740 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.SimpleAlign.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.SimpleAlign import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.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 13b" case13b , testCase "case 14" case14 , testCase "case 15" case15 , testCase "case 16" case16 , testCase "case 17" case17 ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = assertSnippet (step (Just 80) defaultConfig) [ "eitherToMaybe e = case e of" , " Left _ -> Nothing" , " Right x -> Just x" ] [ "eitherToMaybe e = case e of" , " Left _ -> Nothing" , " Right x -> Just x" ] -------------------------------------------------------------------------------- case02 :: Assertion case02 = assertSnippet (step (Just 80) defaultConfig) [ "eitherToMaybe (Left _) = Nothing" , "eitherToMaybe (Right x) = Just x" ] [ "eitherToMaybe (Left _) = Nothing" , "eitherToMaybe (Right x) = Just x" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = assertSnippet (step (Just 80) defaultConfig) [ "heady def [] = def" , "heady _ (x : _) = x" ] [ "heady def [] = def" , "heady _ (x : _) = x" ] -------------------------------------------------------------------------------- case04 :: Assertion case04 = assertSnippet (step (Just 80) defaultConfig) [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" , " } deriving (Show)" ] [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" , " } deriving (Show)" ] -------------------------------------------------------------------------------- case05 :: Assertion case05 = assertSnippet (step (Just 80) defaultConfig) input input where -- Don't attempt to align this since a field spans multiple lines input = [ "data Foo = Foo" , " { foo :: Int" , " , barqux" , " :: String" , " } deriving (Show)" ] -------------------------------------------------------------------------------- case06 :: Assertion case06 = assertSnippet -- 22 max columns is /just/ enough to align this stuff. (step (Just 22) defaultConfig) [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] -------------------------------------------------------------------------------- case07 :: Assertion case07 = assertSnippet -- 21 max columns is /just NOT/ enough to align this stuff. (step (Just 21) defaultConfig) [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] -------------------------------------------------------------------------------- case08 :: Assertion case08 = assertSnippet (step (Just 80) defaultConfig) [ "canDrink mbAge = case mbAge of" , " Just age | age > 18 -> True" , " _ -> False" ] [ "canDrink mbAge = case mbAge of" , " Just age | age > 18 -> True" , " _ -> False" ] -------------------------------------------------------------------------------- case09 :: Assertion case09 = assertSnippet (step Nothing defaultConfig) [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] -------------------------------------------------------------------------------- case10 :: Assertion case10 = assertSnippet (step Nothing defaultConfig) [ "padQual = case align' of" , " Global -> True" , " File -> fileAlign" , " Group -> anyQual" ] [ "padQual = case align' of" , " Global -> True" , " File -> fileAlign" , " Group -> anyQual" ] -------------------------------------------------------------------------------- case11 :: Assertion case11 = assertSnippet (step Nothing defaultConfig) [ "data Foo = Foo" , " { foo :: String" , " , barqux :: !Int" , " }" ] [ "data Foo = Foo" , " { foo :: String" , " , barqux :: !Int" , " }" ] -------------------------------------------------------------------------------- case12 :: Assertion case12 = assertSnippet (step Nothing defaultConfig { cCases = Never }) input input where input = [ "case x of" , " Just y -> 1" , " Nothing -> 2" ] -------------------------------------------------------------------------------- case13 :: Assertion case13 = assertSnippet (step Nothing defaultConfig) [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] case13b :: Assertion case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] -------------------------------------------------------------------------------- case14 :: Assertion case14 = assertSnippet (step (Just 80) defaultConfig { cCases = Adjacent }) [ "catch e = case e of" , " Left GoodError -> 1" , " Left BadError -> 2" , " -- otherwise" , " Right [] -> 0" , " Right (x:_) -> x" ] [ "catch e = case e of" , " Left GoodError -> 1" , " Left BadError -> 2" , " -- otherwise" , " Right [] -> 0" , " Right (x:_) -> x" ] -------------------------------------------------------------------------------- case15 :: Assertion case15 = assertSnippet (step (Just 80) defaultConfig { cTopLevelPatterns = Adjacent }) [ "catch (Left GoodError) = 1" , "catch (Left BadError) = 2" , "-- otherwise" , "catch (Right []) = 0" , "catch (Right (x:_)) = x" ] [ "catch (Left GoodError) = 1" , "catch (Left BadError) = 2" , "-- otherwise" , "catch (Right []) = 0" , "catch (Right (x:_)) = x" ] -------------------------------------------------------------------------------- case16 :: Assertion case16 = assertSnippet (step (Just 80) defaultConfig { cRecords = Adjacent }) [ "data Foo = Foo" , " { foo :: Int" , " , foo2 :: String" , " -- a comment" , " , barqux :: String" , " , baz :: String" , " , baz2 :: Bool" , " } deriving (Show)" ] [ "data Foo = Foo" , " { foo :: Int" , " , foo2 :: String" , " -- a comment" , " , barqux :: String" , " , baz :: String" , " , baz2 :: Bool" , " } deriving (Show)" ] -------------------------------------------------------------------------------- case17 :: Assertion case17 = assertSnippet (step Nothing defaultConfig { cMultiWayIf = Adjacent }) [ "cond n = if" , " | n < 10, x <- 1 -> x" , " -- comment" , " | otherwise -> 2" ] [ "cond n = if" , " | n < 10, x <- 1 -> x" , " -- comment" , " | otherwise -> 2" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Squash/0000755000000000000000000000000007346545000023333 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs0000644000000000000000000000610407346545000024772 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Squash.Tests ( tests ) where -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.Squash import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.SimpleSquash.Tests" [ testCase "case 01" case01 , testCase "case 02" case02 , testCase "case 03" case03 , testCase "case 04" case04 , testCase "case 05" case05 , testCase "case 06 (issue #355)" case06 ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = assertSnippet step [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" , " } deriving (Show)" ] [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" , " } deriving (Show)" ] -------------------------------------------------------------------------------- case02 :: Assertion case02 = assertSnippet step [ "data Foo = Foo" , " { fooqux" , " , bar :: String" , " } deriving (Show)" ] [ "data Foo = Foo" , " { fooqux" , " , bar :: String" , " } deriving (Show)" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = assertSnippet step [ "maybe y0 f mx =" , " case mx of" , " Nothing -> y0" , " Just x -> f x" ] [ "maybe y0 f mx =" , " case mx of" , " Nothing -> y0" , " Just x -> f x" ] -------------------------------------------------------------------------------- case04 :: Assertion case04 = assertSnippet step [ "maybe y0 f mx =" , " case mx of" , " Nothing ->" , " y0" , " Just x ->" , " f x" ] [ "maybe y0 f mx =" , " case mx of" , " Nothing ->" , " y0" , " Just x ->" , " f x" ] -------------------------------------------------------------------------------- case05 :: Assertion case05 = assertSnippet step [ "maybe y0 _ Nothing = y" , "maybe _ f (Just x) = f x" ] [ "maybe y0 _ Nothing = y" , "maybe _ f (Just x) = f x" ] -------------------------------------------------------------------------------- -- See case06 :: Assertion case06 = assertSnippet step [ "main = (\\x -> putStrLn x) \"Hello, World!\"" ] [ "main = (\\x -> putStrLn x) \"Hello, World!\"" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Tabs/0000755000000000000000000000000007346545000022760 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs0000644000000000000000000000222107346545000024413 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} 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 = assertSnippet (step 4) [ "module Main" , "\t\twhere" , "data Foo" , "\t= Bar" , " | Qux" ] [ "module Main" , " where" , "data Foo" , " = Bar" , " | Qux" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/0000755000000000000000000000000007346545000025655 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs0000644000000000000000000000240407346545000027313 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} 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 = assertSnippet step [ "module Main where" , " \t" , "data Foo = Bar | Qux\t " , "\12" -- page break , " \12" -- malformed page break ] [ "module Main where" , "" , "data Foo = Bar | Qux" , "\12" -- page break , "" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/0000755000000000000000000000000007346545000024664 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs0000644000000000000000000000351507346545000026326 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedLists #-} 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 , testCase "case 02" case02 , testCase "case 03" case03 ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = assertSnippet (step True "LANGUAGE") [ "sort :: Ord a => [a] -> [a]" , "sort _ = []" ] [ "{-# LANGUAGE UnicodeSyntax #-}" , "sort ∷ Ord a ⇒ [a] → [a]" , "sort _ = []" ] -------------------------------------------------------------------------------- case02 :: Assertion case02 = assertSnippet (step True "LaNgUaGe") [ "sort :: Ord a => [a] -> [a]" , "sort _ = []" ] [ "{-# LaNgUaGe UnicodeSyntax #-}" , "sort ∷ Ord a ⇒ [a] → [a]" , "sort _ = []" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = assertSnippet (step False "LANGUAGE") [ "x :: Int -> Int -> Int" , "x = undefined" ] [ "x ∷ Int → Int → Int" , "x = undefined" ] stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Tests.hs0000644000000000000000000001200307346545000022606 0ustar0000000000000000-------------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Tests ( tests ) where -------------------------------------------------------------------------------- import Data.List (isInfixOf, sort) import System.Directory (createDirectory) import System.FilePath (normalise, ()) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertFailure, (@?=)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.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 ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = (@?= result) =<< format SearchFromCurrentDirectory Nothing input where input = "module Herp where\ndata Foo = Bar | Baz { baz :: Int }" result = Right $ lines input -------------------------------------------------------------------------------- case02 :: Assertion case02 = withTestDirTree $ do writeFile "test-config.yaml" $ unlines [ "steps:" , " - records:" , " equals: \"indent 2\"" , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 2" , " via: \"indent 2\"" ] actual <- format (UseConfig "test-config.yaml") Nothing input actual @?= result where input = "module Herp where\ndata Foo = Bar | Baz { baz :: Int }" result = Right [ "module Herp where" , "data Foo" , " = Bar" , " | Baz" , " { baz :: Int" , " }" ] -------------------------------------------------------------------------------- case03 :: Assertion case03 = withTestDirTree $ do writeFile "test-config.yaml" $ unlines [ "steps:" , " - records:" , " equals: \"same_line\"" , " first_field: \"same_line\"" , " field_comment: 2" , " deriving: 2" , " via: \"indent 2\"" ] actual <- format (UseConfig "test-config.yaml") Nothing input actual @?= result where input = unlines [ "module Herp where" , "data Foo" , " = Bar" , " | Baz" , " { baz :: Int" , " }" ] result = Right [ "module Herp where" , "data Foo = Bar" , " | Baz { baz :: Int" , " }" ] -------------------------------------------------------------------------------- case04 :: Assertion case04 = format SearchFromCurrentDirectory (Just fileLocation) input >>= \case Right _ -> assertFailure "expected error" Left err | fileLocation `isInfixOf` err , needle `isInfixOf` err -> pure () | otherwise -> assertFailure $ "Unexpected error: " ++ show err where input = "module Herp" fileLocation = "directory/File.hs" needle = "possibly incorrect indentation or mismatched brackets" -------------------------------------------------------------------------------- -- | When providing current dir including folders and files. case05 :: Assertion case05 = withTestDirTree $ do createDirectory aDir >> writeFile c fileCont mapM_ (flip writeFile fileCont) fs result <- findHaskellFiles False input sort result @?= (sort $ map normalise expected) where input = c : fs fs = ["b.hs", "a.hs"] c = aDir "c.hs" aDir = "aDir" expected = ["a.hs", "b.hs", c] fileCont = "" -------------------------------------------------------------------------------- -- | When the input item is not file, do not recurse it. case06 :: Assertion case06 = withTestDirTree $ do mapM_ (flip writeFile "") input result <- findHaskellFiles False input result @?= expected where input = ["b.hs"] expected = map normalise input -------------------------------------------------------------------------------- -- | Empty input should result in empty output. case07 :: Assertion case07 = withTestDirTree $ do mapM_ (flip writeFile "") input result <- findHaskellFiles False input result @?= expected where input = [] expected = input stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Tests/0000755000000000000000000000000007346545000022256 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/Language/Haskell/Stylish/Tests/Util.hs0000644000000000000000000001112007346545000023522 0ustar0000000000000000{-# LANGUAGE BlockArguments #-} {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Tests.Util ( dumpAst , dumpModule , Snippet (..) , assertSnippet , withTestDirTree ) where -------------------------------------------------------------------------------- import Control.Exception (bracket, try) import Data.Data (Data (..)) import GHC.Exts (IsList (..)) import GHC.Hs.Dump (BlankEpAnnotations (..), BlankSrcSpan (..), showAstData) import System.Directory (createDirectory, getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive, setCurrentDirectory) import System.FilePath (()) import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module (Module) import Language.Haskell.Stylish.Parse import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- -- | Takes a Haskell source as an argument and parse it into a Module. -- Extract function selects element from that Module record and returns -- its String representation. -- -- This function should be used when trying to understand how particular -- Haskell code will be represented by ghc-parser's AST dumpAst :: Data a => (Module -> a) -> String -> String dumpAst extract str = let Right(theModule) = parseModule [] Nothing str ast = extract theModule sdoc = showAstData BlankSrcSpan BlankEpAnnotations ast in showOutputable sdoc dumpModule :: String -> String dumpModule = dumpAst id -------------------------------------------------------------------------------- testStep :: Step -> String -> String testStep s str = case s of Step _ step -> case parseModule [] Nothing str of Left err -> error err Right module' -> unlines $ step ls module' where ls = lines str -------------------------------------------------------------------------------- -- | 'Lines' that show as a normal string. newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) -- Prefix with one newline since so HUnit will use a newline after `got: ` or -- `expected: `. instance Show Snippet where show = unlines . ("" :) . unSnippet instance IsList Snippet where type Item Snippet = String fromList = Snippet toList = unSnippet -------------------------------------------------------------------------------- testSnippet :: Step -> Snippet -> Snippet testSnippet s = Snippet . lines . testStep s . unlines . unSnippet -------------------------------------------------------------------------------- assertSnippet :: Step -> Snippet -> Snippet -> Assertion assertSnippet step input expected = expected @=? testSnippet step input -------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template -- provided createTempDirectory :: String -> IO FilePath createTempDirectory template = do tmpRootDir <- getTemporaryDirectory dirId <- randomIO :: IO Word findTempName tmpRootDir dirId where findTempName :: FilePath -> Word -> IO FilePath findTempName tmpRootDir x = do let dirpath = tmpRootDir template ++ show x r <- try $ createDirectory dirpath case r of Right _ -> return dirpath Left e | isAlreadyExistsError e -> findTempName tmpRootDir (x+1) | otherwise -> ioError e -------------------------------------------------------------------------------- -- | Perform an action inside a temporary directory tree and purge the tree -- afterwards withTestDirTree :: IO a -> IO a withTestDirTree action = bracket ((,) <$> getCurrentDirectory <*> createTempDirectory "stylish_haskell") (\(current, temp) -> setCurrentDirectory current *> removeDirectoryRecursive temp) (\(_, temp) -> setCurrentDirectory temp *> action) stylish-haskell-0.15.1.0/tests/0000755000000000000000000000000007346545000014407 5ustar0000000000000000stylish-haskell-0.15.1.0/tests/TestSuite.hs0000644000000000000000000000411607346545000016676 0ustar0000000000000000-------------------------------------------------------------------------------- module Main ( main ) where -------------------------------------------------------------------------------- import Test.Framework (defaultMain) -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Config.Tests import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Data.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests import qualified Language.Haskell.Stylish.Step.Imports.FelixTests import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests import qualified Language.Haskell.Stylish.Step.Squash.Tests import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests import qualified Language.Haskell.Stylish.Regressions -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ Language.Haskell.Stylish.Parse.Tests.tests , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests , Language.Haskell.Stylish.Step.Imports.FelixTests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests , Language.Haskell.Stylish.Step.Squash.Tests.tests , Language.Haskell.Stylish.Step.Tabs.Tests.tests , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests , Language.Haskell.Stylish.Tests.tests , Language.Haskell.Stylish.Regressions.tests ]