├── .gitignore ├── .hlint.yaml ├── LICENSE ├── README.md ├── Setup.hs ├── build.sh ├── format.sh ├── package.yaml ├── src ├── executable │ └── Main.hs └── library │ └── Language │ └── Haskell │ ├── Formatter.hs │ └── Formatter │ ├── CommentCore.hs │ ├── Configuration.hs │ ├── Error.hs │ ├── ExactCode.hs │ ├── Internal │ ├── MapTree.hs │ ├── Newline.hs │ ├── StyleFileFormat.hs │ └── TreeFormat.hs │ ├── Location.hs │ ├── Main.hs │ ├── Process │ ├── AttachComments.hs │ ├── Code.hs │ ├── CodeOrdering.hs │ ├── Control.hs │ ├── DetachComments.hs │ ├── FormatActualCode.hs │ ├── FormatComments.hs │ ├── Formatter.hs │ ├── LineTool.hs │ └── Note.hs │ ├── Result.hs │ ├── Source.hs │ ├── Style.hs │ └── Toolkit │ ├── ListTool.hs │ ├── Splitter.hs │ ├── StreamName.hs │ └── Visit.hs ├── stack.yaml └── testsuite ├── resources ├── examples │ └── default_style.yaml └── source │ ├── comments │ ├── depends_on_displacement │ │ ├── multiple_annotations │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ └── single_annotation │ │ │ ├── line_pair │ │ │ ├── after_after │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── after_before │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── after_none │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── before_after │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── before_before │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── before_none │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── none_after │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── none_before │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── none_none │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── single_line │ │ │ ├── after │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ │ ├── before │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ │ └── none │ │ │ ├── Input.hs │ │ │ └── Output.hs │ ├── empty_lines │ │ ├── at_bounds_of_file │ │ │ ├── end │ │ │ │ ├── 1 │ │ │ │ │ ├── Input.hs │ │ │ │ │ └── Output.hs │ │ │ │ └── 2 │ │ │ │ │ ├── Input.hs │ │ │ │ │ └── Output.hs │ │ │ └── start │ │ │ │ ├── 1 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ │ └── 2 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ ├── between_comments_of_different_declarations │ │ │ ├── 1 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── 2 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ ├── between_comments_of_same_declaration │ │ │ ├── 1 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── 2 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── 3 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ ├── between_declaration_and_comment │ │ │ ├── after │ │ │ │ ├── 1 │ │ │ │ │ ├── Input.hs │ │ │ │ │ └── Output.hs │ │ │ │ └── 2 │ │ │ │ │ ├── Input.hs │ │ │ │ │ └── Output.hs │ │ │ └── before │ │ │ │ ├── 1 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ │ └── 2 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ └── between_top_level_functions │ │ │ ├── with_type_signature │ │ │ ├── 0 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── 1 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── 2 │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── without_type_signature │ │ │ ├── 0 │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ │ ├── 1 │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ │ └── 2 │ │ │ ├── Input.hs │ │ │ └── Output.hs │ ├── indentation │ │ ├── inherits_indentation_of_merged_line │ │ │ ├── actual_code_between_start_and_commented │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ ├── basic │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ │ └── indented_start │ │ │ │ ├── Input.hs │ │ │ │ └── Output.hs │ │ └── keeps_indentation_with_separate_line │ │ │ ├── Input.hs │ │ │ └── Output.hs │ ├── keeps_comments_at_bounds_of_file │ │ ├── end │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ └── start │ │ │ ├── Input.hs │ │ │ └── Output.hs │ └── treats_nested_comments │ │ ├── Input.hs │ │ └── Output.hs │ ├── handles_infix_binding │ ├── Input.hs │ └── Output.hs │ ├── handles_optional_parentheses │ ├── class_constraints │ │ ├── with │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ └── without │ │ │ ├── Input.hs │ │ │ └── Output.hs │ ├── class_inheritance │ │ ├── with │ │ │ ├── Input.hs │ │ │ └── Output.hs │ │ └── without │ │ │ ├── Input.hs │ │ │ └── Output.hs │ └── instances │ │ ├── with │ │ ├── Input.hs │ │ └── Output.hs │ │ └── without │ │ ├── Input.hs │ │ └── Output.hs │ ├── handles_options_ghc_pragma │ ├── Input.hs │ └── Output.hs │ ├── literals │ └── does_not_escape_characters │ │ ├── Input.hs │ │ └── Output.hs │ ├── orders_parts │ ├── import_declarations │ │ ├── Input.hs │ │ └── Output.hs │ ├── import_declarations_and_entities │ │ ├── Input.hs │ │ └── Output.hs │ ├── import_entities_before_declarations │ │ ├── Input.hs │ │ └── Output.hs │ ├── nested_import_entities │ │ ├── Input.hs │ │ └── Output.hs │ ├── nested_import_entities_before_root_entities │ │ ├── Input.hs │ │ └── Output.hs │ └── root_import_entities │ │ ├── Input.hs │ │ └── Output.hs │ └── terminates_file_with_newline │ ├── Input.hs │ └── Output.hs └── src ├── Language └── Haskell │ └── Formatter │ ├── Internal │ └── Tests.hs │ ├── Tests.hs │ └── Toolkit │ ├── FileTesting.hs │ ├── FileTree.hs │ └── TestTool.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /haskell-formatter.cabal 2 | /.stack-work/ 3 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - group: { name: dollar, enabled: true } 2 | - group: { name: generalise, enabled: true } 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2014 Benjamin Fischer 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell Formatter 2 | 3 | [![License](https://img.shields.io/github/license/evolutics/haskell-formatter.svg)](LICENSE) 4 | [![Package](https://img.shields.io/hackage/v/haskell-formatter.svg)](https://hackage.haskell.org/package/haskell-formatter) 5 | 6 | This is [**deprecated**](#deprecation-notice). 7 | 8 | The Haskell Formatter formats Haskell source code. It is strict in that it fundamentally rearranges code. 9 | 10 | ## Deprecation notice 11 | 12 | The Haskell Formatter is deprecated. If you think it should still be maintained, please let me know. 13 | 14 | Take a look at the following projects, which aim at formatting Haskell code, too. 15 | 16 | - [brittany](https://github.com/lspitzner/brittany) 17 | - [hfmt](https://github.com/danstiner/hfmt) 18 | - [hindent](https://github.com/mihaimaruseac/hindent) 19 | - [stylish-haskell](https://github.com/jaspervdj/stylish-haskell) 20 | 21 | Personally, I like **hindent,** to which you can migrate as follows. 22 | 23 | | Use case | Haskell Formatter | hindent | 24 | | ------------------------------ | ------------------------------------------------------ | -------------------------- | 25 | | Format file in-place | `haskell-formatter --force --input a.hs --output a.hs` | `hindent a.hs` | 26 | | Format multiple files in-place | [Not supported out-of-the-box](#formatting-many-files) | `hindent a.hs b.hs` | 27 | | Format stdin to stdout | `haskell-formatter` | `hindent` | 28 | | Order imports | Done by [default](#style-configuration) | `hindent --sort-imports …` | 29 | | Get help | `haskell-formatter --help` | `hindent --help` | 30 | 31 | ## Installation 32 | 33 | Install it by running 34 | 35 | ```bash 36 | stack install haskell-formatter 37 | ``` 38 | 39 | or 40 | 41 | ```bash 42 | cabal new-install haskell-formatter 43 | ``` 44 | 45 | You are ready when 46 | 47 | ```bash 48 | haskell-formatter --help 49 | ``` 50 | 51 | works. 52 | 53 | ## Usage 54 | 55 | ### Basics 56 | 57 | Read source code from `Input.hs`, format it, and write it to `Output.hs` by 58 | 59 | ```bash 60 | haskell-formatter --input Input.hs --output Output.hs 61 | ``` 62 | 63 | If the input or output file is not given, it defaults to the corresponding standard stream. This allows commands like 64 | 65 | ```bash 66 | haskell-formatter < Input.hs 67 | ``` 68 | 69 | To format a file in-place, use the `--force` option as in 70 | 71 | ```bash 72 | # Warning: this overwrites the file `Code.hs`. 73 | haskell-formatter --force --input Code.hs --output Code.hs 74 | ``` 75 | 76 | For more help about the usage, call 77 | 78 | ```bash 79 | haskell-formatter --help 80 | ``` 81 | 82 | ### Formatting Many Files 83 | 84 | For a diff of how code in the current folder would be formatted, without actually changing anything, run 85 | 86 | ```bash 87 | find . -name '*.hs' -type f -print0 \ 88 | | xargs -0 -n 1 bash -c 'haskell-formatter < "$@" | diff -u "$@" -' -- 89 | ``` 90 | 91 | The returned exit status is nonzero if there are unformatted files. This may be useful for continuous integration. 92 | 93 | To format any `*.hs` files in a folder `code/` or (recursively) in its subfolders, run 94 | 95 | ```bash 96 | # Warning: this overwrites files, so better back them up first. 97 | find code/ -name '*.hs' -type f -print0 \ 98 | | xargs -0 -I {} -n 1 haskell-formatter --force --input {} --output {} 99 | ``` 100 | 101 | ### Style Configuration 102 | 103 | The formatting style can be configured with a file referred by the `--style` option. For instance, the call 104 | 105 | ```bash 106 | haskell-formatter --style my_style.yaml --input Input.hs --output Output.hs 107 | ``` 108 | 109 | uses `my_style.yaml` as a style file. Such files are in the [YAML format](http://en.wikipedia.org/wiki/YAML). The following is an [example style file](testsuite/resources/examples/default_style.yaml), which at the same time shows the available keys with their default values. 110 | 111 | 114 | 115 | ```yaml 116 | # Lines should be no longer than this length in characters. 117 | line_length_limit: 80 118 | 119 | # How much to spread code over multiple lines instead of trying to fill a single 120 | # line. More precisely, this guides the ratio of "line_length_limit" to the 121 | # ribbon length (the number of characters on a line without leading and trailing 122 | # whitespace). Only the lowest value of 1 forces "line_length_limit" to be 123 | # applied strictly. 124 | # Reference: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777 125 | ribbons_per_line: 1 126 | 127 | # More than this number of empty lines in succession are merged. 128 | successive_empty_lines_limit: 1 129 | 130 | # Indentation lengths in characters. 131 | indentations: 132 | class: 8 # "class" and "instance" declarations. 133 | do: 3 # "do" notation. 134 | case: 4 # Body of "case" expressions. 135 | let: 4 # Declarations in "let" expressions. 136 | where: 6 # Declarations in "where" clauses. 137 | onside: 2 # Continuation lines which would otherwise be offside. 138 | 139 | # Decides which parts of the code to sort. 140 | order: 141 | # Sequence of import declarations. 142 | import_declarations: true 143 | 144 | # Entities of import lists. 145 | import_entities: true 146 | ``` 147 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o errexit -o nounset -o pipefail 4 | 5 | cd -- "$(dirname -- "$0")" 6 | stack --system-ghc test 7 | -------------------------------------------------------------------------------- /format.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o errexit -o nounset -o pipefail 4 | 5 | find Setup.hs src testsuite/src -name '*.hs' -type f -print0 \ 6 | | xargs -0 -I {} -n 1 stack run -- --force --input {} --output {} 7 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: haskell-formatter 2 | version: "2.0.3" 3 | synopsis: Haskell source code formatter 4 | description: > 5 | The Haskell Formatter formats Haskell source code. It is strict in that it 6 | fundamentally rearranges code. 7 | category: Development 8 | author: Benjamin Fischer 9 | maintainer: Benjamin Fischer 10 | copyright: (C) 2014 Benjamin Fischer 11 | license: MIT 12 | github: evolutics/haskell-formatter.git 13 | extra-source-files: 14 | - format.sh 15 | - .gitignore 16 | - .hlint.yaml 17 | - README.md 18 | - testsuite/resources/examples/default_style.yaml 19 | dependencies: 20 | - base >= 4.6 && < 5 21 | library: 22 | source-dirs: src/library 23 | ghc-options: -Wall 24 | exposed-modules: 25 | - Language.Haskell.Formatter 26 | - Language.Haskell.Formatter.Internal.MapTree 27 | - Language.Haskell.Formatter.Internal.Newline 28 | - Language.Haskell.Formatter.Internal.StyleFileFormat 29 | - Language.Haskell.Formatter.Internal.TreeFormat 30 | dependencies: 31 | - containers 32 | - haskell-src-exts 33 | - scientific 34 | - text 35 | - unordered-containers 36 | - yaml 37 | executables: 38 | haskell-formatter: 39 | main: Main.hs 40 | source-dirs: src/executable 41 | ghc-options: -Wall 42 | dependencies: 43 | - directory 44 | - filepath 45 | - haskell-formatter 46 | - optparse-applicative 47 | tests: 48 | test: 49 | main: Main.hs 50 | source-dirs: testsuite/src 51 | ghc-options: -Wall 52 | dependencies: 53 | - containers 54 | - directory-tree 55 | - doctest 56 | - filemanip 57 | - filepath 58 | - haskell-formatter 59 | - hlint 60 | - QuickCheck 61 | - tasty 62 | - tasty-hunit 63 | -------------------------------------------------------------------------------- /src/executable/Main.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Root of executable 3 | -} 4 | module Main (main) where 5 | import qualified Data.Foldable as Foldable 6 | import qualified Data.Function as Function 7 | import qualified Data.List as List 8 | import qualified Data.Monoid as Monoid 9 | import qualified Language.Haskell.Formatter as Formatter 10 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 11 | import qualified Language.Haskell.Formatter.Internal.StyleFileFormat 12 | as StyleFileFormat 13 | import qualified Language.Haskell.Formatter.Internal.TreeFormat as TreeFormat 14 | import qualified Options.Applicative as Applicative 15 | import qualified System.Directory as Directory 16 | import qualified System.Exit as Exit 17 | import qualified System.FilePath as FilePath 18 | import qualified System.IO as IO 19 | 20 | data Arguments = Arguments{input :: Maybe FilePath, output :: Maybe FilePath, 21 | force :: Bool, styleFile :: Maybe FilePath} 22 | deriving (Eq, Ord, Show) 23 | 24 | main :: IO () 25 | main 26 | = do arguments <- Applicative.execParser utilityUsage 27 | maybeError <- formatWithUncheckedArguments arguments 28 | Foldable.mapM_ exitWithError maybeError 29 | where exitWithError errorMessage 30 | = putErrorLine errorMessage >> Exit.exitFailure 31 | putErrorLine = IO.hPutStrLn IO.stderr 32 | 33 | utilityUsage :: Applicative.ParserInfo Arguments 34 | utilityUsage = Applicative.info parserWithHelp modifier 35 | where parserWithHelp = Applicative.helper Applicative.<*> argumentParser 36 | modifier 37 | = Monoid.mconcat 38 | [Applicative.fullDesc, oneLineDescription, description] 39 | oneLineDescription 40 | = Applicative.header 41 | "Haskell Formatter – A Haskell source code formatter" 42 | description 43 | = Applicative.progDesc $ 44 | createParagraphs 45 | [["The Haskell Formatter formats Haskell source code. ", 46 | "It is strict in that it fundamentally rearranges code."], 47 | ["The source code is read from INPUT, ", 48 | "formatted, and written to OUTPUT."]] 49 | 50 | argumentParser :: Applicative.Parser Arguments 51 | argumentParser 52 | = Arguments Applicative.<$> inputOption Applicative.<*> outputOption 53 | Applicative.<*> forceOption 54 | Applicative.<*> styleOption 55 | where inputOption 56 | = Applicative.optional . Applicative.strOption $ 57 | Monoid.mconcat 58 | [Applicative.short 'i', Applicative.long "input", 59 | Applicative.metavar "INPUT", 60 | Applicative.help 61 | "Input source code file (default: standard input)"] 62 | outputOption 63 | = Applicative.optional . Applicative.strOption $ 64 | Monoid.mconcat 65 | [Applicative.short 'o', Applicative.long "output", 66 | Applicative.metavar "OUTPUT", 67 | Applicative.help 68 | "Output source code file (default: standard output)"] 69 | forceOption 70 | = Applicative.switch $ 71 | Monoid.mconcat 72 | [Applicative.short forceStandardName, Applicative.long "force", 73 | Applicative.help 74 | "Allows the output file to overwrite the input file"] 75 | styleOption 76 | = Applicative.optional . Applicative.strOption $ 77 | Monoid.mconcat 78 | [Applicative.short 's', Applicative.long "style", 79 | Applicative.metavar "STYLE", 80 | Applicative.help "Formatting style file"] 81 | 82 | forceStandardName :: Char 83 | forceStandardName = 'f' 84 | 85 | createParagraphs :: [[String]] -> String 86 | createParagraphs 87 | = Newline.joinSeparatedLines . List.intersperse emptyLine . fmap concat 88 | where emptyLine = "" 89 | 90 | formatWithUncheckedArguments :: Arguments -> IO (Maybe String) 91 | formatWithUncheckedArguments arguments 92 | = do maybeError <- checkArguments arguments 93 | case maybeError of 94 | Nothing -> formatWithCheckedArguments arguments 95 | Just errorMessage -> return $ Just errorMessage 96 | 97 | checkArguments :: Arguments -> IO (Maybe String) 98 | checkArguments arguments 99 | = case (maybeInput, maybeOutput) of 100 | (Just inputPath, Just outputPath) -> if forceOverwriting then 101 | return Nothing else 102 | do same <- sameExistentPaths 103 | inputPath 104 | outputPath 105 | return $ 106 | if same then 107 | Just overwritingError else 108 | Nothing 109 | where overwritingError 110 | = concat 111 | ["The output path ", show outputPath, 112 | " would overwrite the input path ", show inputPath, ". ", 113 | "Either use unequal paths or apply the ", 114 | show forceStandardName, " option, please."] 115 | _ -> return Nothing 116 | where maybeInput = input arguments 117 | maybeOutput = output arguments 118 | forceOverwriting = force arguments 119 | 120 | {-| Do both file paths exist and refer to the same file or folder? -} 121 | sameExistentPaths :: FilePath -> FilePath -> IO Bool 122 | sameExistentPaths left right 123 | = do exist <- bothPathsExist 124 | if exist then 125 | liftedOn FilePath.equalFilePath Directory.canonicalizePath left right 126 | else return False 127 | where bothPathsExist = liftedOn (&&) pathExists left right 128 | liftedOn = Function.on . Applicative.liftA2 129 | pathExists path 130 | = Applicative.liftA2 (||) (Directory.doesFileExist path) $ 131 | Directory.doesDirectoryExist path 132 | 133 | formatWithCheckedArguments :: Arguments -> IO (Maybe String) 134 | formatWithCheckedArguments arguments 135 | = do maybeConfiguration <- getConfiguration arguments 136 | case maybeConfiguration of 137 | Left errorMessage -> return $ Just errorMessage 138 | Right configuration -> formatWithConfiguration arguments 139 | configuration 140 | 141 | getConfiguration :: Arguments -> IO (Either String Formatter.Configuration) 142 | getConfiguration arguments 143 | = do maybeStyle <- getStyle arguments 144 | return $ 145 | case maybeStyle of 146 | Left message -> Left message 147 | Right style -> Right configuration 148 | where configuration 149 | = defaults{Formatter.configurationStyle = style} 150 | where defaults 151 | = Formatter.defaultConfiguration{Formatter.configurationStreamName = 152 | stream} 153 | stream 154 | = maybe Formatter.standardInput Formatter.createStreamName maybeInput 155 | maybeInput = input arguments 156 | 157 | getStyle :: Arguments -> IO (Either String Formatter.Style) 158 | getStyle arguments 159 | = case styleFile arguments of 160 | Nothing -> return $ Right defaultStyle 161 | Just file -> TreeFormat.parseYamlFile StyleFileFormat.treeFormat 162 | defaultStyle 163 | file 164 | where defaultStyle 165 | = Formatter.configurationStyle Formatter.defaultConfiguration 166 | 167 | formatWithConfiguration :: 168 | Arguments -> 169 | Formatter.Configuration -> IO (Maybe String) 170 | formatWithConfiguration arguments configuration 171 | = do inputString <- readInput 172 | case Formatter.format configuration inputString of 173 | Left libraryError -> return . Just $ showError libraryError 174 | Right outputString -> do evaluateString outputString $ 175 | writeOutput outputString 176 | return Nothing 177 | where readInput = maybe getContents readFile maybeInput 178 | maybeInput = input arguments 179 | evaluateString string = seq $ length string 180 | writeOutput = maybe putStr writeFile maybeOutput 181 | maybeOutput = output arguments 182 | 183 | showError :: Formatter.Error -> String 184 | showError libraryError 185 | = if Formatter.isAssertionError libraryError then assertionError else rawError 186 | where assertionError 187 | = createParagraphs 188 | [["Oops, an error occurred. ", "Feel free to report this, ", 189 | "because it appears to be a bug. Thanks! ", 190 | "The specific error message follows."], 191 | [rawError]] 192 | rawError = show libraryError 193 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Haskell source code formatter 3 | -} 4 | module Language.Haskell.Formatter 5 | (module Configuration, Error.Error, Error.isAssertionError, 6 | Main.defaultFormat, Main.format, StreamName.createStreamName, 7 | StreamName.standardInput, StreamName.StreamName, module Style) 8 | where 9 | import Language.Haskell.Formatter.Configuration as Configuration hiding (check) 10 | import qualified Language.Haskell.Formatter.Error as Error 11 | import qualified Language.Haskell.Formatter.Main as Main 12 | import Language.Haskell.Formatter.Style as Style hiding (check) 13 | import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName 14 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/CommentCore.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Comments without location 3 | -} 4 | module Language.Haskell.Formatter.CommentCore 5 | (CommentCore, kind, content, Kind(..), DocumentationDisplacement(..), 6 | create, wrappedLineCount, documentationDisplacement) 7 | where 8 | import qualified Data.Char as Char 9 | import qualified Data.Monoid as Monoid 10 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 11 | import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool 12 | 13 | data CommentCore = CommentCore{kind :: Kind, content :: String} 14 | deriving (Eq, Ord) 15 | 16 | data Kind = Ordinary 17 | | Nested 18 | deriving (Eq, Ord, Show) 19 | 20 | data DocumentationDisplacement = BeforeActualCode 21 | | AfterActualCode 22 | | None 23 | deriving (Eq, Ord, Show) 24 | 25 | instance Show CommentCore where 26 | show comment 27 | = case kind comment of 28 | Ordinary -> Monoid.mappend "--" rawContent 29 | Nested -> concat ["{-", rawContent, "-}"] 30 | where rawContent = content comment 31 | 32 | create :: Kind -> String -> CommentCore 33 | create rawKind rawContent = CommentCore{kind = rawKind, content = rawContent} 34 | 35 | wrappedLineCount :: CommentCore -> Int 36 | wrappedLineCount = length . Newline.splitSeparatedLines . show 37 | 38 | documentationDisplacement :: CommentCore -> DocumentationDisplacement 39 | documentationDisplacement comment 40 | = case unwrappedContent of 41 | ('|' : _) -> BeforeActualCode 42 | ('^' : _) -> AfterActualCode 43 | _ -> None 44 | where unwrappedContent 45 | = ListTool.dropWhileAtMost Char.isSpace spaceLimit $ content comment 46 | spaceLimit = 1 47 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Configuration.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Overall configuration 3 | -} 4 | module Language.Haskell.Formatter.Configuration 5 | (Configuration, configurationStyle, configurationStreamName, 6 | defaultConfiguration, check) 7 | where 8 | import qualified Language.Haskell.Formatter.Result as Result 9 | import qualified Language.Haskell.Formatter.Source as Source 10 | import qualified Language.Haskell.Formatter.Style as Style 11 | import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName 12 | 13 | data Configuration = Configuration{configurationStyle :: Style.Style, 14 | configurationStreamName :: 15 | StreamName.StreamName} 16 | deriving (Eq, Ord, Show) 17 | 18 | defaultConfiguration :: Configuration 19 | defaultConfiguration 20 | = Configuration{configurationStyle = Style.defaultStyle, 21 | configurationStreamName = stream} 22 | where stream = StreamName.createStreamName filename 23 | filename = Source.parseFilename Source.defaultParseMode 24 | 25 | check :: Configuration -> Result.Result () 26 | check = Style.check . configurationStyle 27 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Errors for feedback to users 3 | -} 4 | module Language.Haskell.Formatter.Error 5 | (Error, createStyleFormatError, createParseError, createAssertionError, 6 | isAssertionError) 7 | where 8 | import qualified Language.Haskell.Formatter.Location as Location 9 | import qualified Language.Haskell.Formatter.Source as Source 10 | 11 | data Error = StyleFormatError String 12 | | ParseError Location.SrcLoc String 13 | | AssertionError String 14 | deriving (Eq, Ord) 15 | 16 | instance Show Error where 17 | show (StyleFormatError message) = message 18 | show (ParseError position message) 19 | = concat [Source.prettyPrint position, separator, message] 20 | where separator = ": " 21 | show (AssertionError message) = message 22 | 23 | createStyleFormatError :: String -> Error 24 | createStyleFormatError = StyleFormatError 25 | 26 | createParseError :: Location.SrcLoc -> String -> Error 27 | createParseError = ParseError 28 | 29 | createAssertionError :: String -> Error 30 | createAssertionError = AssertionError 31 | 32 | isAssertionError :: Error -> Bool 33 | isAssertionError (StyleFormatError _) = False 34 | isAssertionError (ParseError _ _) = False 35 | isAssertionError (AssertionError _) = True 36 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/ExactCode.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Exact syntax tree as parsed and printed by HSE 3 | -} 4 | module Language.Haskell.Formatter.ExactCode 5 | (ExactCode, actualCode, comments, create) where 6 | import qualified Language.Haskell.Formatter.Location as Location 7 | import qualified Language.Haskell.Formatter.Source as Source 8 | 9 | data ExactCode = ExactCode{actualCode :: Source.Module Location.SrcSpanInfo, 10 | comments :: [Source.Comment]} 11 | 12 | instance Show ExactCode where 13 | show exact = Source.exactPrint rawActualCode rawComments 14 | where rawActualCode = actualCode exact 15 | rawComments = comments exact 16 | 17 | instance Location.Portioned ExactCode where 18 | getPortion = Location.getPortion . actualCode 19 | 20 | create :: Source.Module Location.SrcSpanInfo -> [Source.Comment] -> ExactCode 21 | create rawActualCode rawComments 22 | = ExactCode{actualCode = rawActualCode, comments = rawComments} 23 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Internal/MapTree.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Trees with unique labels 3 | -} 4 | module Language.Haskell.Formatter.Internal.MapTree 5 | (MapTree(..), MapForest, isEmpty, summarizeLeaves, indentTree) where 6 | import qualified Control.Applicative as Applicative 7 | import qualified Control.Monad as Monad 8 | import qualified Data.Map.Strict as Map 9 | import qualified Data.Monoid as Monoid 10 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 11 | 12 | data MapTree k a = Leaf a 13 | | Node (MapForest k a) 14 | deriving (Eq, Ord, Show) 15 | 16 | type MapForest k a = Map.Map k (MapTree k a) 17 | 18 | instance Functor (MapTree k) where 19 | fmap function (Leaf value) = Leaf $ function value 20 | fmap function (Node forest) = Node $ fmap (fmap function) forest 21 | 22 | isEmpty :: MapTree k a -> Bool 23 | isEmpty (Leaf _) = False 24 | isEmpty (Node forest) = Map.null forest 25 | 26 | summarizeLeaves :: 27 | (Ord k, Monoid.Monoid b) => 28 | MapForest k (Either a b) -> MapTree k (Either a (Map.Map k b)) 29 | summarizeLeaves = summarize Map.empty 30 | where summarize labels root 31 | = if Map.null lefts then 32 | if Map.null forests then Leaf . Right $ labels' else 33 | fromMap (summarize labels') forests 34 | else fromMap (Leaf . Left) lefts 35 | where (lefts, rights) = Map.mapEither id values 36 | (values, forests) = Map.mapEither distinguish root 37 | distinguish (Leaf value) = Left value 38 | distinguish (Node forest) = Right forest 39 | labels' = Map.unionWith Monoid.mappend labels rights 40 | fromMap function = Node . fmap function 41 | 42 | indentTree :: MapTree String String -> String 43 | indentTree = Newline.joinSeparatedLines . indentLines 44 | where indentLines (Leaf value) = Newline.splitSeparatedLines value 45 | indentLines (Node forest) = foldMapWithKey indentBinding forest 46 | foldMapWithKey create = uncurry create Monad.<=< Map.toAscList 47 | indentBinding label tree = Monoid.mappend labelLines treeLines 48 | where labelLines = Newline.splitSeparatedLines label 49 | treeLines = indent Applicative.<$> indentLines tree 50 | indent = (indentation ++) 51 | indentation = " " 52 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Internal/Newline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Handling Unicode newlines 3 | -} 4 | module Language.Haskell.Formatter.Internal.Newline 5 | (newlines, joinSeparatedLines, splitSeparatedLines) where 6 | import qualified Data.List as List 7 | import qualified Language.Haskell.Formatter.Toolkit.Splitter as Splitter 8 | 9 | {-| Unicode newline strings ordered by descending length. This corresponds to 10 | the set of newlines from 11 | . -} 12 | newlines :: [String] 13 | newlines = ["\CR\LF", "\LF", "\VT", "\FF", "\CR", "\x85", "\x2028", "\x2029"] 14 | 15 | {-| Concatenates strings with default newlines @\"\\n\"@ between. 16 | 17 | Unlike 'unlines', this does not append a newline to the last string. 18 | 19 | >>> joinSeparatedLines ["apple", "pine"] 20 | "apple\npine" -} 21 | joinSeparatedLines :: [String] -> String 22 | joinSeparatedLines = List.intercalate defaultNewline 23 | where defaultNewline = "\LF" 24 | 25 | {-| Breaks a string up into its lines at 'newlines'. The resulting strings do 26 | not contain 'newlines'. 27 | 28 | Unlike 'lines', this interprets a newline as a separator, not a terminator. 29 | Thus, if the input string ends with a newline, the output list ends with the 30 | empty string. 31 | 32 | >>> splitSeparatedLines "0\n1\r2\r\n3\n\r4" 33 | ["0","1","2","3","","4"] 34 | 35 | prop> last (splitSeparatedLines $ s ++ "\LF") == "" -} 36 | splitSeparatedLines :: String -> [String] 37 | splitSeparatedLines = Splitter.separate newlines 38 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Internal/StyleFileFormat.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Sample format definition for a style file 3 | -} 4 | module Language.Haskell.Formatter.Internal.StyleFileFormat (treeFormat) where 5 | import qualified Data.Map as Map 6 | import qualified Language.Haskell.Formatter as Formatter 7 | import qualified Language.Haskell.Formatter.Internal.MapTree as MapTree 8 | import qualified Language.Haskell.Formatter.Internal.TreeFormat as TreeFormat 9 | 10 | treeFormat :: TreeFormat.TreeFormat Formatter.Style 11 | treeFormat 12 | = Map.fromList 13 | [("line_length_limit", 14 | MapTree.Leaf . TreeFormat.LimitedInteger $ 15 | \ value style -> style{Formatter.lineLengthLimit = value}), 16 | ("ribbons_per_line", 17 | MapTree.Leaf . TreeFormat.SingleFloating $ 18 | \ value style -> style{Formatter.ribbonsPerLine = value}), 19 | ("successive_empty_lines_limit", 20 | MapTree.Leaf . TreeFormat.LimitedInteger $ 21 | \ value style -> style{Formatter.successiveEmptyLinesLimit = value}), 22 | ("indentations", 23 | MapTree.Node $ 24 | Map.fromList 25 | [("class", 26 | MapTree.Leaf . TreeFormat.LimitedInteger $ 27 | \ value style -> style{Formatter.classIndentation = value}), 28 | ("do", 29 | MapTree.Leaf . TreeFormat.LimitedInteger $ 30 | \ value style -> style{Formatter.doIndentation = value}), 31 | ("case", 32 | MapTree.Leaf . TreeFormat.LimitedInteger $ 33 | \ value style -> style{Formatter.caseIndentation = value}), 34 | ("let", 35 | MapTree.Leaf . TreeFormat.LimitedInteger $ 36 | \ value style -> style{Formatter.letIndentation = value}), 37 | ("where", 38 | MapTree.Leaf . TreeFormat.LimitedInteger $ 39 | \ value style -> style{Formatter.whereIndentation = value}), 40 | ("onside", 41 | MapTree.Leaf . TreeFormat.LimitedInteger $ 42 | \ value style -> style{Formatter.onsideIndentation = value})]), 43 | ("order", 44 | MapTree.Node $ 45 | Map.fromList 46 | [("import_declarations", 47 | MapTree.Leaf . TreeFormat.Boolean $ 48 | \ value style -> 49 | style{Formatter.orderImportDeclarations = value}), 50 | ("import_entities", 51 | MapTree.Leaf . TreeFormat.Boolean $ 52 | \ value style -> 53 | style{Formatter.orderImportEntities = value})])] 54 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Internal/TreeFormat.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Parsing nested maps according to a format 3 | -} 4 | module Language.Haskell.Formatter.Internal.TreeFormat 5 | (TreeFormat, Leaf(..), parseYamlFile) where 6 | import qualified Control.Arrow as Arrow 7 | import qualified Data.HashMap.Strict as HashMap 8 | import qualified Data.Map.Strict as Map 9 | import qualified Data.Monoid as Monoid 10 | import qualified Data.Scientific as Scientific 11 | import qualified Data.Text as Text 12 | import qualified Data.Yaml as Yaml 13 | import qualified Language.Haskell.Formatter.Internal.MapTree as MapTree 14 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 15 | 16 | type TreeFormat a = MapTree.MapForest String (Leaf a) 17 | 18 | data Leaf a = Boolean (RawLeaf Bool a) 19 | | LimitedInteger (RawLeaf Int a) 20 | | SingleFloating (RawLeaf Float a) 21 | 22 | type RawLeaf a b = a -> b -> b 23 | 24 | parseYamlFile :: TreeFormat a -> a -> FilePath -> IO (Either String a) 25 | parseYamlFile format ball file 26 | = do maybeValue <- Yaml.decodeFileEither file 27 | let interpretation 28 | = case maybeValue of 29 | Left exception -> Left $ show exception 30 | Right value -> defaultInterpret format value ball 31 | return $ Arrow.left fileError interpretation 32 | where fileError message = Newline.joinSeparatedLines [introduction, message] 33 | introduction = Monoid.mappend file ":" 34 | 35 | defaultInterpret :: TreeFormat a -> Yaml.Value -> a -> Either String a 36 | defaultInterpret format value ball 37 | = if MapTree.isEmpty errors then Right interpretation else 38 | Left $ MapTree.indentTree errors 39 | where (errors, interpretation) = interpret format value ball 40 | 41 | interpret :: 42 | TreeFormat a -> Yaml.Value -> a -> (MapTree.MapTree String String, a) 43 | interpret formatMap (Yaml.Object rawValueMap) ball = (errorNode, ball') 44 | where errorNode = MapTree.Node $ Map.mapMaybe id errorTree 45 | (ball', errorTree) = Map.mapAccumWithKey move ball valueMap 46 | move ballPart key value = (ballPart', maybeErrors) 47 | where (maybeErrors, ballPart') = matchTree maybeFormat value ballPart 48 | maybeFormat = Map.lookup key formatMap 49 | valueMap = Map.mapKeys Text.unpack $ orderedMap rawValueMap 50 | orderedMap = Map.fromList . HashMap.toList 51 | interpret _ value ball = (errorLeaf, ball) 52 | where errorLeaf = MapTree.Leaf $ unexpectedMessage "a map" value 53 | 54 | matchTree :: 55 | Maybe (MapTree.MapTree String (Leaf a)) -> 56 | Yaml.Value -> a -> (Maybe (MapTree.MapTree String String), a) 57 | matchTree Nothing _ ball = (Just $ MapTree.Leaf message, ball) 58 | where message = "Unexpected key." 59 | matchTree (Just (MapTree.Leaf leaf)) value ball 60 | = case matchLeaf leaf value ball of 61 | Left message -> (Just $ MapTree.Leaf message, ball) 62 | Right ball' -> (Nothing, ball') 63 | matchTree (Just (MapTree.Node node)) value ball = (maybeErrors, ball') 64 | where maybeErrors = if MapTree.isEmpty errors then Nothing else Just errors 65 | (errors, ball') = interpret node value ball 66 | 67 | matchLeaf :: Leaf a -> Yaml.Value -> a -> Either String a 68 | matchLeaf (Boolean go) (Yaml.Bool boolean) ball = Right $ go boolean ball 69 | matchLeaf (LimitedInteger go) value@(Yaml.Number number) ball 70 | = case Scientific.toBoundedInteger number of 71 | Nothing -> Left message 72 | where message = unexpectedMessage "a limited integer" value 73 | Just integer -> Right $ go integer ball 74 | matchLeaf (SingleFloating go) (Yaml.Number number) ball 75 | = Right $ go floating ball 76 | where floating = Scientific.toRealFloat number 77 | matchLeaf format value _ = Left $ unexpectedMessage expected value 78 | where expected 79 | = case format of 80 | Boolean _ -> "a Boolean" 81 | LimitedInteger _ -> "a limited integer" 82 | SingleFloating _ -> "a single-precision floating-point number" 83 | 84 | unexpectedMessage :: String -> Yaml.Value -> String 85 | unexpectedMessage expected actualValue 86 | = Newline.joinSeparatedLines [introduction, actual] 87 | where introduction = concat ["Expected ", expected, ", but got:"] 88 | actual = show $ Yaml.encode actualValue 89 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Location.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Facade for the location handling of HSE 3 | 4 | See also "Language.Haskell.Formatter.Source". 5 | -} 6 | module Language.Haskell.Formatter.Location 7 | (SrcLoc.SrcLoc, SrcLoc.SrcSpan, SrcLoc.SrcSpanInfo, base, plus, minus, 8 | Portioned(..), Line, Column, streamName, getLine, getColumn, 9 | createPosition, SrcLoc.getPointLoc, getEndPosition, 10 | replaceNestedPortionLines, stringPortion, getStartLine, getStartColumn, 11 | getEndLine, getEndColumn) 12 | where 13 | import qualified Data.Function as Function 14 | import qualified Language.Haskell.Exts.Comments as Comments 15 | import qualified Language.Haskell.Exts.SrcLoc as SrcLoc 16 | import qualified Language.Haskell.Exts.Syntax as Syntax 17 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 18 | import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool 19 | import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName 20 | import Prelude hiding (getLine) 21 | 22 | class Enum a => Natural a where 23 | 24 | base :: a 25 | 26 | plus :: Integral b => b -> a -> a 27 | plus difference natural 28 | = toEnum $ fromIntegral difference + fromEnum natural 29 | 30 | minus :: Num b => a -> a -> b 31 | minus minuend = fromIntegral . Function.on (-) fromEnum minuend 32 | 33 | class Portioned a where 34 | 35 | getPortion :: a -> SrcLoc.SrcSpan 36 | 37 | newtype Line = Line Int 38 | deriving (Eq, Ord, Show) 39 | 40 | newtype Column = Column Int 41 | deriving (Eq, Ord, Show) 42 | 43 | instance Enum Line where 44 | toEnum = Line 45 | fromEnum (Line line) = line 46 | 47 | instance Enum Column where 48 | toEnum = Column 49 | fromEnum (Column column) = column 50 | 51 | instance Natural Line where 52 | base = Line 1 53 | 54 | instance Natural Column where 55 | base = Column 1 56 | 57 | instance Portioned SrcLoc.SrcSpanInfo where 58 | getPortion = SrcLoc.srcInfoSpan 59 | 60 | instance Portioned a => Portioned (Syntax.Module a) where 61 | getPortion = getPortion . Syntax.ann 62 | 63 | instance Portioned Comments.Comment where 64 | getPortion (Comments.Comment _ commentPortion _) = commentPortion 65 | 66 | streamName :: SrcLoc.SrcInfo a => a -> StreamName.StreamName 67 | streamName = StreamName.createStreamName . SrcLoc.fileName 68 | 69 | getLine :: SrcLoc.SrcLoc -> Line 70 | getLine = Line . SrcLoc.srcLine 71 | 72 | getColumn :: SrcLoc.SrcLoc -> Column 73 | getColumn = Column . SrcLoc.srcColumn 74 | 75 | createPosition :: StreamName.StreamName -> Line -> Column -> SrcLoc.SrcLoc 76 | createPosition stream (Line line) (Column column) 77 | = SrcLoc.SrcLoc{SrcLoc.srcFilename = show stream, SrcLoc.srcLine = line, 78 | SrcLoc.srcColumn = column} 79 | 80 | getEndPosition :: SrcLoc.SrcSpan -> SrcLoc.SrcLoc 81 | getEndPosition portion = createPosition stream line column 82 | where stream = streamName portion 83 | line = Line $ SrcLoc.srcSpanEndLine portion 84 | column = Column $ SrcLoc.srcSpanEndColumn portion 85 | 86 | replaceNestedPortionLines :: 87 | (Line -> Line) -> 88 | SrcLoc.SrcSpanInfo -> SrcLoc.SrcSpanInfo 89 | replaceNestedPortionLines function nestedPortion 90 | = nestedPortion{SrcLoc.srcInfoSpan = parent', 91 | SrcLoc.srcInfoPoints = children'} 92 | where parent' = replace parent 93 | replace = replacePortionLines function 94 | parent = SrcLoc.srcInfoSpan nestedPortion 95 | children' = fmap replace children 96 | children = SrcLoc.srcInfoPoints nestedPortion 97 | 98 | replacePortionLines :: (Line -> Line) -> SrcLoc.SrcSpan -> SrcLoc.SrcSpan 99 | replacePortionLines function portion 100 | = portion{SrcLoc.srcSpanStartLine = start, SrcLoc.srcSpanEndLine = end} 101 | where Line start = function $ getStartLine portion 102 | Line end = function $ getEndLine portion 103 | 104 | stringPortion :: SrcLoc.SrcLoc -> String -> SrcLoc.SrcSpan 105 | stringPortion startPosition string = SrcLoc.mkSrcSpan startPosition endPosition 106 | where endPosition = createPosition stream endLine endColumn 107 | stream = streamName startPosition 108 | endLine = lastIndex lineCount startLine 109 | lastIndex difference = pred . plus difference 110 | lineCount = length stringLines 111 | stringLines = Newline.splitSeparatedLines string 112 | startLine = getStartLine startPosition 113 | endColumn = lastIndex lastLineLength lastLineStartColumn 114 | lastLineLength = maybe 0 length $ ListTool.maybeLast stringLines 115 | lastLineStartColumn = if hasSingleLine then startColumn else base 116 | hasSingleLine = lineCount == 1 117 | startColumn = getStartColumn startPosition 118 | 119 | getStartLine :: SrcLoc.SrcInfo a => a -> Line 120 | getStartLine = getLine . SrcLoc.getPointLoc 121 | 122 | getStartColumn :: SrcLoc.SrcInfo a => a -> Column 123 | getStartColumn = getColumn . SrcLoc.getPointLoc 124 | 125 | getEndLine :: SrcLoc.SrcSpan -> Line 126 | getEndLine = getLine . getEndPosition 127 | 128 | getEndColumn :: SrcLoc.SrcSpan -> Column 129 | getEndColumn = getColumn . getEndPosition 130 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Main.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Root of formatting 3 | -} 4 | module Language.Haskell.Formatter.Main (defaultFormat, format) where 5 | import qualified Language.Haskell.Formatter.Configuration as Configuration 6 | import qualified Language.Haskell.Formatter.Error as Error 7 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 8 | import qualified Language.Haskell.Formatter.Process.Control as Control 9 | import qualified Language.Haskell.Formatter.Result as Result 10 | import qualified Language.Haskell.Formatter.Source as Source 11 | import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName 12 | 13 | defaultFormat :: String -> Either Error.Error String 14 | defaultFormat = format Configuration.defaultConfiguration 15 | 16 | format :: Configuration.Configuration -> String -> Either Error.Error String 17 | format configuration = Result.toEither . tryFormat configuration 18 | 19 | tryFormat :: Configuration.Configuration -> String -> Result.Result String 20 | tryFormat configuration source 21 | = do Configuration.check configuration 22 | exact <- parse stream source 23 | exact' <- Control.format style exact 24 | return $ show exact' 25 | where stream = Configuration.configurationStreamName configuration 26 | style = Configuration.configurationStyle configuration 27 | 28 | parse :: StreamName.StreamName -> String -> Result.Result ExactCode.ExactCode 29 | parse stream source 30 | = case parseResult of 31 | Source.ParseFailed position message -> Result.fatalError parseError 32 | where parseError = Error.createParseError position message 33 | Source.ParseOk (actualCode, comments) -> return exact 34 | where exact = ExactCode.create actualCode comments 35 | where parseResult = Source.parseFileContentsWithComments mode source 36 | mode = Source.defaultParseMode{Source.parseFilename = show stream} 37 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/AttachComments.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Attaching comments to the annotations of the syntax tree 3 | 4 | This is the first part of the process. 5 | -} 6 | module Language.Haskell.Formatter.Process.AttachComments (attachComments) where 7 | import qualified Data.Foldable as Foldable 8 | import qualified Data.Function as Function 9 | import qualified Data.List as List 10 | import qualified Data.Map.Strict as Map 11 | import qualified Data.Monoid as Monoid 12 | import qualified Data.Semigroup as Semigroup 13 | import qualified Data.Traversable as Traversable 14 | import qualified Language.Haskell.Formatter.CommentCore as CommentCore 15 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 16 | import qualified Language.Haskell.Formatter.Location as Location 17 | import qualified Language.Haskell.Formatter.Process.Code as Code 18 | import qualified Language.Haskell.Formatter.Process.LineTool as LineTool 19 | import qualified Language.Haskell.Formatter.Process.Note as Note 20 | import qualified Language.Haskell.Formatter.Result as Result 21 | import qualified Language.Haskell.Formatter.Source as Source 22 | import qualified Language.Haskell.Formatter.Style as Style 23 | 24 | newtype Assignment = Assignment (Map.Map Location.SrcSpan Note.CommentNote) 25 | deriving (Eq, Ord, Show) 26 | 27 | data CodeGap = InfiniteLower Location.SrcSpan 28 | | FiniteGap Location.SrcSpan Location.SrcSpan 29 | | InfiniteUpper Location.SrcSpan 30 | deriving (Eq, Ord, Show) 31 | 32 | instance Semigroup.Semigroup Assignment where 33 | (Assignment left) <> (Assignment right) = Assignment merged 34 | where merged = Map.unionWith Monoid.mappend left right 35 | 36 | instance Monoid.Monoid Assignment where 37 | mempty = Assignment Map.empty 38 | 39 | attachComments :: 40 | Style.Style -> 41 | ExactCode.ExactCode -> Result.Result Code.CommentableCode 42 | attachComments _ exact 43 | = do assignment <- assignForCode exact 44 | let (Assignment unassigned, commentable) = spread assignment locatable 45 | if Map.null unassigned then return commentable else 46 | Result.fatalAssertionError message 47 | where locatable = ExactCode.actualCode exact 48 | message = "Attaching the comments failed with an unassigned rest." 49 | 50 | assignForCode :: ExactCode.ExactCode -> Result.Result Assignment 51 | assignForCode exact 52 | = case unassigned of 53 | [] -> return $ Monoid.mconcat assignments 54 | (_ : _) -> Result.fatalAssertionError message 55 | where ((_, unassigned), assignments) 56 | = Traversable.mapAccumL move base maybeOrderedPortions 57 | move (maybeLower, rest) maybeUpper = ((maybeUpper, rest'), assignment) 58 | where (rest', assignment) 59 | = case maybeUpper of 60 | Nothing -> case maybeLower of 61 | Nothing -> (rest, Monoid.mempty) 62 | Just lower -> ([], 63 | assign 64 | (InfiniteUpper lower) 65 | rest) 66 | Just upper -> (greaterUpper, assign gap lessEqualUpper) 67 | where (lessEqualUpper, greaterUpper) 68 | = span ((<= upper) . Location.getPortion) rest 69 | gap 70 | = case maybeLower of 71 | Nothing -> InfiniteLower upper 72 | Just lower -> FiniteGap lower upper 73 | assign gap = assignComments gap . createComments startLine endLine 74 | where (startLine, endLine) 75 | = case gap of 76 | InfiniteLower upper -> (pred Location.base, 77 | Location.getStartLine upper) 78 | FiniteGap lower upper -> (Location.getEndLine lower, 79 | Location.getStartLine upper) 80 | InfiniteUpper lower -> (Location.getEndLine lower, 81 | codeEndLine) 82 | codeEndLine = Location.getEndLine $ Location.getPortion exact 83 | base = (Nothing, orderedComments) 84 | (orderedPortions, orderedComments) = orderByStartEnd exact 85 | maybeOrderedPortions 86 | = Monoid.mappend (fmap Just orderedPortions) [Nothing] 87 | message = "Assigning the comments failed with an unexpected rest." 88 | 89 | assignComments :: CodeGap -> [Note.CommentBox] -> Assignment 90 | assignComments (InfiniteLower upper) comments = assignBefore upper comments 91 | assignComments (FiniteGap lower upper) comments 92 | = Monoid.mappend assignedAfter assignedBefore 93 | where assignedAfter = assignAfter lower after 94 | (after, spaces, before) = divideComments comments 95 | assignedBefore = assignBefore upper $ Monoid.mappend spaces before 96 | assignComments (InfiniteUpper lower) comments = assignAfter lower comments 97 | 98 | assignBefore :: Location.SrcSpan -> [Note.CommentBox] -> Assignment 99 | assignBefore portion = flip (assignSingleton portion) [] 100 | 101 | assignSingleton :: 102 | Location.SrcSpan -> 103 | [Note.CommentBox] -> [Note.CommentBox] -> Assignment 104 | assignSingleton portion before after = Assignment $ Map.singleton portion note 105 | where note = Note.createCommentNote before after 106 | 107 | assignAfter :: Location.SrcSpan -> [Note.CommentBox] -> Assignment 108 | assignAfter portion = assignSingleton portion [] 109 | 110 | divideComments :: 111 | [Note.CommentBox] -> 112 | ([Note.CommentBox], [Note.CommentBox], [Note.CommentBox]) 113 | divideComments = divide [] [] 114 | where divide after spaces [] = (after, spaces, []) 115 | divide after spaces rest@(box@(Note.ActualComment comment) : unwrapped) 116 | = case (after, spaces) of 117 | (_ : _, []) -> ifAfter 118 | _ -> case displacement of 119 | CommentCore.BeforeActualCode -> ifBefore 120 | CommentCore.AfterActualCode -> ifAfter 121 | CommentCore.None -> ifBefore 122 | where ifAfter = divide (concat [after, spaces, [box]]) [] unwrapped 123 | displacement = CommentCore.documentationDisplacement core 124 | core = Note.commentCore comment 125 | ifBefore = (after, spaces, rest) 126 | divide after spaces (Note.EmptyLine : unwrapped) 127 | = divide after (Monoid.mappend spaces [Note.EmptyLine]) unwrapped 128 | 129 | createComments :: 130 | Location.Line -> 131 | Location.Line -> [Source.Comment] -> [Note.CommentBox] 132 | createComments gapStartLine gapEndLine comments 133 | = Monoid.mappend (concat untilLast) lastBoxes 134 | where (lastEndLine, untilLast) 135 | = Traversable.mapAccumL create gapStartLine comments 136 | create endLine comment = (endLine', boxes) 137 | where endLine' = Location.getEndLine portion 138 | portion = Location.getPortion comment 139 | boxes = Monoid.mappend emptyLines actualComments 140 | emptyLines = createEmptyLines endLine startLine 141 | startLine = Location.getStartLine portion 142 | actualComments = [Note.ActualComment indentedComment] 143 | indentedComment = Note.createIndentedComment core Location.base 144 | core = Source.commentCore comment 145 | lastBoxes = createEmptyLines lastEndLine gapEndLine 146 | 147 | createEmptyLines :: Location.Line -> Location.Line -> [Note.CommentBox] 148 | createEmptyLines endLine startLine = replicate emptyLineCount Note.EmptyLine 149 | where emptyLineCount = LineTool.countEmptyLines endLine startLine 150 | 151 | orderByStartEnd :: ExactCode.ExactCode -> ([Location.SrcSpan], [Source.Comment]) 152 | orderByStartEnd exact = (orderedPortions, orderedComments) 153 | where orderedPortions = fmap Location.getPortion nestedPortions 154 | nestedPortions = List.sort $ Foldable.toList actualCode 155 | actualCode = ExactCode.actualCode exact 156 | orderedComments 157 | = List.sortBy (Function.on compare Location.getPortion) comments 158 | comments = ExactCode.comments exact 159 | 160 | spread :: Assignment -> Code.LocatableCode -> (Assignment, Code.CommentableCode) 161 | spread (Assignment assignment) locatable = (Assignment unassigned, commentable) 162 | where (unassigned, commentable) 163 | = Traversable.mapAccumL move assignment locatable 164 | move rest nestedPortion = (rest', note) 165 | where (maybeNote, rest') = Map.updateLookupWithKey remove portion rest 166 | remove = const . const Nothing 167 | portion = Location.getPortion nestedPortion 168 | note = Foldable.fold maybeNote 169 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/Code.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Syntax tree types 3 | -} 4 | module Language.Haskell.Formatter.Process.Code 5 | (LocatableCode, CommentableCode, LocatableCommentableCode, tryZipCode, 6 | tryZipLocationsComments, dropComments, dropLocations) 7 | where 8 | import qualified Language.Haskell.Formatter.Location as Location 9 | import qualified Language.Haskell.Formatter.Process.Note as Note 10 | import qualified Language.Haskell.Formatter.Result as Result 11 | import qualified Language.Haskell.Formatter.Source as Source 12 | import qualified Language.Haskell.Formatter.Toolkit.Visit as Visit 13 | 14 | type LocatableCode = Source.Module Location.SrcSpanInfo 15 | 16 | type CommentableCode = Source.Module Note.CommentNote 17 | 18 | type LocatableCommentableCode = Source.Module Note.LocationCommentNote 19 | 20 | tryZipCode :: 21 | (a -> b -> c) -> 22 | Source.Module a -> 23 | Source.Module b -> Result.Result (Source.Module c) 24 | tryZipCode merge left right 25 | = case maybeZipped of 26 | Nothing -> Result.fatalAssertionError message 27 | where message = "The code notes could not be zipped." 28 | Just zipped -> return zipped 29 | where maybeZipped 30 | = if isActualCodeSame then Visit.halfZipWith merge left right else 31 | Nothing 32 | isActualCodeSame = left Source.=~= right 33 | 34 | tryZipLocationsComments :: 35 | LocatableCode -> 36 | CommentableCode -> 37 | Result.Result LocatableCommentableCode 38 | tryZipLocationsComments = tryZipCode Note.createLocationCommentNote 39 | 40 | dropComments :: LocatableCommentableCode -> LocatableCode 41 | dropComments = fmap Note.locationNote 42 | 43 | dropLocations :: LocatableCommentableCode -> CommentableCode 44 | dropLocations = fmap Note.commentNote 45 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/CodeOrdering.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Sorting parts of code where the order is irrelevant 3 | -} 4 | module Language.Haskell.Formatter.Process.CodeOrdering 5 | (orderImportDeclarations, orderRootImportEntities, 6 | orderNestedImportEntities) 7 | where 8 | import qualified Language.Haskell.Exts.Syntax as Syntax 9 | import qualified Language.Haskell.Formatter.Process.Code as Code 10 | import qualified Language.Haskell.Formatter.Source as Source 11 | import qualified Language.Haskell.Formatter.Toolkit.Visit as Visit 12 | 13 | orderImportDeclarations :: 14 | Code.LocatableCommentableCode -> 15 | Code.LocatableCommentableCode 16 | orderImportDeclarations = replaceImportDeclarations $ Visit.orderByKey key 17 | where key 18 | (Syntax.ImportDecl _ moduleName isQualified isWithSource isSafe 19 | package alias entitiesList) 20 | = (moduleNameKey moduleName, isQualified, isWithSource, isSafe, 21 | package, fmap moduleNameKey alias, 22 | fmap entitiesListKey entitiesList) 23 | moduleNameKey (Syntax.ModuleName _ name) = name 24 | entitiesListKey (Syntax.ImportSpecList _ isHiding entities) 25 | = (isHiding, fmap importEntityKey entities) 26 | 27 | replaceImportDeclarations :: 28 | ([Syntax.ImportDecl a] -> [Syntax.ImportDecl a]) -> 29 | Source.Module a -> Source.Module a 30 | replaceImportDeclarations function (Syntax.Module a h p importDeclarations d) 31 | = Syntax.Module a h p importDeclarations' d 32 | where importDeclarations' = function importDeclarations 33 | replaceImportDeclarations _ xmlPage@Syntax.XmlPage{} = xmlPage 34 | replaceImportDeclarations function 35 | (Syntax.XmlHybrid a h p importDeclarations d xn xa me e) 36 | = Syntax.XmlHybrid a h p importDeclarations' d xn xa me e 37 | where importDeclarations' = function importDeclarations 38 | 39 | importEntityKey :: Syntax.ImportSpec a -> [String] 40 | importEntityKey (Syntax.IVar _ name) = rootNameKey name 41 | importEntityKey (Syntax.IAbs _ _ name) = rootNameKey name 42 | importEntityKey (Syntax.IThingAll _ name) = rootNameKey name 43 | importEntityKey (Syntax.IThingWith _ name entities) 44 | = nameKey name : fmap nestedImportEntityKey entities 45 | 46 | rootNameKey :: Syntax.Name a -> [String] 47 | rootNameKey name = [nameKey name] 48 | 49 | nameKey :: Syntax.Name a -> String 50 | nameKey (Syntax.Ident _ name) = name 51 | nameKey (Syntax.Symbol _ name) = name 52 | 53 | nestedImportEntityKey :: Syntax.CName a -> String 54 | nestedImportEntityKey (Syntax.VarName _ name) = nameKey name 55 | nestedImportEntityKey (Syntax.ConName _ name) = nameKey name 56 | 57 | orderRootImportEntities :: 58 | Code.LocatableCommentableCode -> 59 | Code.LocatableCommentableCode 60 | orderRootImportEntities 61 | = replaceImportEntities $ Visit.orderByKey importEntityKey 62 | 63 | replaceImportEntities :: 64 | ([Syntax.ImportSpec a] -> [Syntax.ImportSpec a]) -> 65 | Source.Module a -> Source.Module a 66 | replaceImportEntities function 67 | = replaceImportDeclarations $ fmap replaceDeclaration 68 | where replaceDeclaration importDeclaration 69 | = importDeclaration{Syntax.importSpecs = entitiesList'} 70 | where entitiesList' = fmap replaceList entitiesList 71 | entitiesList = Syntax.importSpecs importDeclaration 72 | replaceList (Syntax.ImportSpecList annotation isHiding entities) 73 | = Syntax.ImportSpecList annotation isHiding entities' 74 | where entities' = function entities 75 | 76 | orderNestedImportEntities :: 77 | Code.LocatableCommentableCode -> 78 | Code.LocatableCommentableCode 79 | orderNestedImportEntities 80 | = replaceNestedImportEntities $ Visit.orderByKey nestedImportEntityKey 81 | 82 | replaceNestedImportEntities :: 83 | ([Syntax.CName a] -> [Syntax.CName a]) -> 84 | Source.Module a -> Source.Module a 85 | replaceNestedImportEntities function = replaceImportEntities $ fmap replace 86 | where replace (Syntax.IThingWith annotation name entities) 87 | = Syntax.IThingWith annotation name entities' 88 | where entities' = function entities 89 | replace entity = entity 90 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/Control.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Formatting process itself 3 | -} 4 | module Language.Haskell.Formatter.Process.Control (format) where 5 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 6 | import qualified Language.Haskell.Formatter.Process.AttachComments 7 | as AttachComments 8 | import qualified Language.Haskell.Formatter.Process.DetachComments 9 | as DetachComments 10 | import qualified Language.Haskell.Formatter.Process.FormatActualCode 11 | as FormatActualCode 12 | import qualified Language.Haskell.Formatter.Process.FormatComments 13 | as FormatComments 14 | import qualified Language.Haskell.Formatter.Process.Formatter as Formatter 15 | import qualified Language.Haskell.Formatter.Result as Result 16 | import qualified Language.Haskell.Formatter.Style as Style 17 | 18 | format :: 19 | Style.Style -> ExactCode.ExactCode -> Result.Result ExactCode.ExactCode 20 | format style = Formatter.format $ createFormatter style 21 | 22 | createFormatter :: Style.Style -> Formatter.Formatter 23 | createFormatter style 24 | = Formatter.Formatter{Formatter.attachComments = 25 | AttachComments.attachComments style, 26 | Formatter.formatActualCode = 27 | FormatActualCode.formatActualCode style, 28 | Formatter.formatComments = 29 | FormatComments.formatComments style, 30 | Formatter.detachComments = 31 | DetachComments.detachComments style} 32 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/DetachComments.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Detaching comments from the annotations of the syntax tree 3 | 4 | This is the last part of the process. 5 | -} 6 | module Language.Haskell.Formatter.Process.DetachComments (detachComments) where 7 | import qualified Data.Foldable as Foldable 8 | import qualified Data.List as List 9 | import qualified Data.Map.Strict as Map 10 | import qualified Data.Maybe as Maybe 11 | import qualified Data.Monoid as Monoid 12 | import qualified Data.Semigroup as Semigroup 13 | import qualified Language.Haskell.Formatter.CommentCore as CommentCore 14 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 15 | import qualified Language.Haskell.Formatter.Location as Location 16 | import qualified Language.Haskell.Formatter.Process.Code as Code 17 | import qualified Language.Haskell.Formatter.Process.LineTool as LineTool 18 | import qualified Language.Haskell.Formatter.Process.Note as Note 19 | import qualified Language.Haskell.Formatter.Result as Result 20 | import qualified Language.Haskell.Formatter.Source as Source 21 | import qualified Language.Haskell.Formatter.Style as Style 22 | import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool 23 | import qualified Language.Haskell.Formatter.Toolkit.StreamName as StreamName 24 | 25 | newtype Reservation = Reservation (Map.Map Location.Line [Note.CommentBox]) 26 | deriving (Eq, Ord, Show) 27 | 28 | instance Semigroup.Semigroup Reservation where 29 | (Reservation left) <> (Reservation right) = Reservation merged 30 | where merged = Map.unionWith merge left right 31 | merge before after = concat [before, between, after] 32 | where between 33 | = [Note.EmptyLine | 34 | hasActualComment (ListTool.maybeLast before) && 35 | hasActualComment (Maybe.listToMaybe after)] 36 | hasActualComment maybeComment 37 | = case maybeComment of 38 | Nothing -> False 39 | Just (Note.ActualComment _) -> True 40 | Just Note.EmptyLine -> False 41 | 42 | instance Monoid.Monoid Reservation where 43 | mempty = Reservation Map.empty 44 | 45 | detachComments :: 46 | Style.Style -> 47 | Code.LocatableCommentableCode -> 48 | Result.Result ExactCode.ExactCode 49 | detachComments _ locatableCommentable 50 | = return $ ExactCode.create locatable' comments 51 | where locatable' = LineTool.shiftCode shifter locatable 52 | shifter = reservationShifter reservation 53 | reservation = reserveForCode locatableCommentable 54 | locatable = Code.dropComments locatableCommentable 55 | comments = createComments stream reservation 56 | stream = Location.streamName $ Location.getPortion locatable' 57 | 58 | reservationShifter :: Reservation -> LineTool.Shifter 59 | reservationShifter (Reservation reservation) 60 | = LineTool.createShifter $ fmap commentsShift reservation 61 | 62 | commentsShift :: [Note.CommentBox] -> LineTool.Shift 63 | commentsShift = sum . fmap commentShift 64 | 65 | commentShift :: Note.CommentBox -> LineTool.Shift 66 | commentShift (Note.ActualComment comment) 67 | = CommentCore.wrappedLineCount $ Note.commentCore comment 68 | commentShift Note.EmptyLine = 1 69 | 70 | reserveForCode :: Code.LocatableCommentableCode -> Reservation 71 | reserveForCode = Foldable.foldMap reserveForNote 72 | 73 | reserveForNote :: Note.LocationCommentNote -> Reservation 74 | reserveForNote note = Monoid.mappend before after 75 | where before = singleton lineBefore $ Note.commentsBefore commentNote 76 | singleton line = Reservation . Map.singleton line 77 | lineBefore = Location.getStartLine portion 78 | portion = Location.getPortion note 79 | commentNote = Note.commentNote note 80 | after = singleton lineAfter $ Note.commentsAfter commentNote 81 | lineAfter = succ $ Location.getEndLine portion 82 | 83 | createComments :: StreamName.StreamName -> Reservation -> [Source.Comment] 84 | createComments stream = accumulateReservation create 85 | where create baseLine = snd . List.foldl' merge (baseLine, []) 86 | merge (startLine, comments) box = (followingLine, comments') 87 | where followingLine = Location.plus shift startLine 88 | shift = commentShift box 89 | comments' = Monoid.mappend comments commentsNow 90 | commentsNow 91 | = case box of 92 | Note.ActualComment comment -> [createComment stream 93 | startLine 94 | comment] 95 | Note.EmptyLine -> [] 96 | 97 | accumulateReservation :: 98 | Monoid.Monoid m => 99 | (Location.Line -> [Note.CommentBox] -> m) -> 100 | Reservation -> m 101 | accumulateReservation create (Reservation reservation) = accumulation 102 | where (_, accumulation) = Map.foldlWithKey' accumulate base reservation 103 | accumulate (absoluteShift, structure) line comments 104 | = (absoluteShift', structure') 105 | where absoluteShift' = absoluteShift + relativeShift 106 | relativeShift = commentsShift comments 107 | structure' = Monoid.mappend structure part 108 | part = create shiftedLine comments 109 | shiftedLine = Location.plus absoluteShift line 110 | base = (noShift, Monoid.mempty) 111 | noShift = 0 112 | 113 | createComment :: 114 | StreamName.StreamName -> 115 | Location.Line -> Note.IndentedComment -> Source.Comment 116 | createComment stream startLine comment = Source.createComment core portion 117 | where core = Note.commentCore comment 118 | portion = Location.stringPortion startPosition wrappedComment 119 | startPosition = Location.createPosition stream startLine startColumn 120 | startColumn = Note.commentStartColumn comment 121 | wrappedComment = show core 122 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/FormatActualCode.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Rearranging the actual code (not the comments) 3 | -} 4 | module Language.Haskell.Formatter.Process.FormatActualCode (formatActualCode) 5 | where 6 | import qualified Control.Applicative as Applicative 7 | import qualified Language.Haskell.Formatter.Process.Code as Code 8 | import qualified Language.Haskell.Formatter.Process.CodeOrdering as CodeOrdering 9 | import qualified Language.Haskell.Formatter.Result as Result 10 | import qualified Language.Haskell.Formatter.Source as Source 11 | import qualified Language.Haskell.Formatter.Style as Style 12 | import qualified Language.Haskell.Formatter.Toolkit.Visit as Visit 13 | 14 | formatActualCode :: 15 | Style.Style -> 16 | Code.LocatableCommentableCode -> 17 | Result.Result Code.LocatableCommentableCode 18 | formatActualCode style locatableCommentable 19 | = do locatable <- prettyPrint style locatableCommentable' 20 | Code.tryZipLocationsComments locatable commentable 21 | where locatableCommentable' = prepare style locatableCommentable 22 | commentable = Code.dropLocations locatableCommentable' 23 | 24 | prettyPrint :: 25 | Style.Style -> 26 | Code.LocatableCommentableCode -> Result.Result Code.LocatableCode 27 | prettyPrint style locatableCommentable 28 | = case parseResult of 29 | Source.ParseFailed _ _ -> Result.fatalAssertionError message 30 | where message = "Formatting the actual code failed to parse." 31 | Source.ParseOk possiblyChanged -> tryUnwrap maybeLocatable' 32 | where maybeLocatable' 33 | = Visit.halfZipWith (const id) locatable possiblyChanged 34 | where parseResult 35 | = Source.parseFileContents $ defaultPrettyPrint style locatable 36 | locatable = Code.dropComments locatableCommentable 37 | tryUnwrap maybeLocatable' 38 | = case maybeLocatable' of 39 | Nothing -> Result.fatalAssertionError message 40 | where message = "Formatting the actual code failed to zip." 41 | Just locatable' -> return locatable' 42 | 43 | defaultPrettyPrint :: Source.Pretty a => Style.Style -> a -> String 44 | defaultPrettyPrint 45 | = Applicative.liftA2 Source.prettyPrintStyleMode renderingStyle mode 46 | 47 | renderingStyle :: Style.Style -> Source.Style 48 | renderingStyle style 49 | = Source.style{Source.lineLength = Style.lineLengthLimit style, 50 | Source.ribbonsPerLine = Style.ribbonsPerLine style} 51 | 52 | mode :: Style.Style -> Source.PPHsMode 53 | mode style 54 | = Source.defaultMode{Source.classIndent = Style.classIndentation style, 55 | Source.doIndent = Style.doIndentation style, 56 | Source.caseIndent = Style.caseIndentation style, 57 | Source.letIndent = Style.letIndentation style, 58 | Source.whereIndent = Style.whereIndentation style, 59 | Source.onsideIndent = Style.onsideIndentation style} 60 | 61 | prepare :: 62 | Style.Style -> 63 | Code.LocatableCommentableCode -> Code.LocatableCommentableCode 64 | prepare style = Visit.compose preparations 65 | where preparations 66 | = [preparation | (isApplied, preparation) <- applications, 67 | isApplied style] 68 | applications 69 | = [(Style.orderImportDeclarations, 70 | CodeOrdering.orderImportDeclarations), 71 | (Style.orderImportEntities, orderImportEntities)] 72 | 73 | orderImportEntities :: 74 | Code.LocatableCommentableCode -> 75 | Code.LocatableCommentableCode 76 | orderImportEntities 77 | = CodeOrdering.orderRootImportEntities . 78 | CodeOrdering.orderNestedImportEntities 79 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/FormatComments.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Rearranging the comments 3 | -} 4 | module Language.Haskell.Formatter.Process.FormatComments (formatComments) where 5 | import qualified Data.Function as Function 6 | import qualified Data.Monoid as Monoid 7 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 8 | import qualified Language.Haskell.Formatter.Location as Location 9 | import qualified Language.Haskell.Formatter.Process.AttachComments 10 | as AttachComments 11 | import qualified Language.Haskell.Formatter.Process.Code as Code 12 | import qualified Language.Haskell.Formatter.Process.Note as Note 13 | import qualified Language.Haskell.Formatter.Result as Result 14 | import qualified Language.Haskell.Formatter.Style as Style 15 | import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool 16 | import qualified Language.Haskell.Formatter.Toolkit.Visit as Visit 17 | 18 | formatComments :: 19 | Style.Style -> 20 | Code.LocatableCommentableCode -> 21 | Result.Result Code.LocatableCommentableCode 22 | formatComments style locatableCommentable 23 | = do locatableCommentable' <- mergeImpliedComments style locatableCommentable 24 | return . indentToLineStart $ 25 | mergeSuccessiveEmptyLines style locatableCommentable' 26 | 27 | mergeImpliedComments :: 28 | Style.Style -> 29 | Code.LocatableCommentableCode -> 30 | Result.Result Code.LocatableCommentableCode 31 | mergeImpliedComments style locatableCommentable 32 | = do impliedCommentable <- commentsImpliedByLocations style locatable 33 | commentable' <- commentsDifference style commentable impliedCommentable 34 | Code.tryZipLocationsComments locatable commentable' 35 | where locatable = Code.dropComments locatableCommentable 36 | commentable = Code.dropLocations locatableCommentable 37 | 38 | commentsImpliedByLocations :: 39 | Style.Style -> 40 | Code.LocatableCode -> 41 | Result.Result Code.CommentableCode 42 | commentsImpliedByLocations style locatable 43 | = AttachComments.attachComments style exact 44 | where exact = ExactCode.create locatable comments 45 | comments = [] 46 | 47 | commentsDifference :: 48 | Style.Style -> 49 | Code.CommentableCode -> 50 | Code.CommentableCode -> 51 | Result.Result Code.CommentableCode 52 | commentsDifference style = Code.tryZipCode minus 53 | where minus mixed implied 54 | = Note.createCommentNote commentsBefore commentsAfter 55 | where commentsBefore = difference Note.commentsBefore 56 | difference getComments 57 | = Function.on (boxesDifference style) getComments mixed 58 | implied 59 | commentsAfter 60 | = reverse . difference $ reverse . Note.commentsAfter 61 | 62 | boxesDifference :: 63 | Style.Style -> 64 | [Note.CommentBox] -> [Note.CommentBox] -> [Note.CommentBox] 65 | boxesDifference style mixed implied = Monoid.mappend difference mixedRest 66 | where difference = replicate differenceCount Note.EmptyLine 67 | differenceCount 68 | = if mixedCount <= impliedCount then 0 else 69 | clip mixedCount - impliedCount 70 | mixedCount = length mixedEmptyLines 71 | (mixedEmptyLines, mixedRest) = span isEmptyLine mixed 72 | impliedCount = length implied 73 | clip = min successiveEmptyLinesLimit 74 | successiveEmptyLinesLimit = Style.successiveEmptyLinesLimit style 75 | 76 | isEmptyLine :: Note.CommentBox -> Bool 77 | isEmptyLine (Note.ActualComment _) = False 78 | isEmptyLine Note.EmptyLine = True 79 | 80 | indentToLineStart :: 81 | Code.LocatableCommentableCode -> Code.LocatableCommentableCode 82 | indentToLineStart locatableCommentable = locatableCommentable' 83 | where (_, locatableCommentable') 84 | = Visit.mapAccumulateLeftWithCreation move startPosition 85 | locatableCommentable 86 | move lineStart note = (lineStart', Note.replaceCommentNote replace note) 87 | where lineStart' 88 | = if 89 | Function.on (==) Location.getStartLine noteStart lineStart 90 | then lineStart else noteStart 91 | noteStart = startPosition note 92 | replace = Note.replaceCommentStartColumn indent 93 | indent = const $ Location.getStartColumn lineStart' 94 | startPosition = Location.getPointLoc . Location.getPortion 95 | 96 | mergeSuccessiveEmptyLines :: 97 | Style.Style -> 98 | Code.LocatableCommentableCode -> 99 | Code.LocatableCommentableCode 100 | mergeSuccessiveEmptyLines style 101 | = fmap . Note.replaceCommentNote $ Note.replaceCommentBoxes merge 102 | where merge 103 | = ListTool.mergeLongerSuccessions isEmptyLine 104 | successiveEmptyLinesLimit 105 | successiveEmptyLinesLimit = Style.successiveEmptyLinesLimit style 106 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/Formatter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Invocation of the process parts with assertion checking 3 | -} 4 | module Language.Haskell.Formatter.Process.Formatter (Formatter(..), format) 5 | where 6 | import qualified Control.Monad as Monad 7 | import qualified Data.Function as Function 8 | import qualified Language.Haskell.Formatter.ExactCode as ExactCode 9 | import qualified Language.Haskell.Formatter.Process.Code as Code 10 | import qualified Language.Haskell.Formatter.Result as Result 11 | import qualified Language.Haskell.Formatter.Source as Source 12 | 13 | class Coded a where 14 | 15 | getCode :: a -> Source.Module () 16 | 17 | data Formatter = Formatter{attachComments :: 18 | ExactCode.ExactCode -> 19 | Result.Result Code.CommentableCode, 20 | formatActualCode :: 21 | Code.LocatableCommentableCode -> 22 | Result.Result Code.LocatableCommentableCode, 23 | formatComments :: 24 | Code.LocatableCommentableCode -> 25 | Result.Result Code.LocatableCommentableCode, 26 | detachComments :: 27 | Code.LocatableCommentableCode -> 28 | Result.Result ExactCode.ExactCode} 29 | 30 | instance Coded (Source.Module a) where 31 | getCode = Monad.void 32 | 33 | instance Coded ExactCode.ExactCode where 34 | getCode = getCode . ExactCode.actualCode 35 | 36 | format :: Formatter -> ExactCode.ExactCode -> Result.Result ExactCode.ExactCode 37 | format formatter exact 38 | = do commentable <- checkedAttachComments formatter exact 39 | locatableCommentable <- Code.tryZipLocationsComments locatable 40 | commentable 41 | {- Formatting the actual code is allowed to change the code itself. -} 42 | locatableCommentable' <- formatActualCode formatter locatableCommentable 43 | locatableCommentable'' <- checkedFormatComments formatter 44 | locatableCommentable' 45 | checkedDetachComments formatter locatableCommentable'' 46 | where locatable = ExactCode.actualCode exact 47 | 48 | checkedAttachComments :: 49 | Formatter -> 50 | ExactCode.ExactCode -> 51 | Result.Result Code.CommentableCode 52 | checkedAttachComments formatter 53 | = transformNotes (attachComments formatter) message 54 | where message = "Attaching the comments changed the code itself." 55 | 56 | transformNotes :: 57 | (Coded a, Coded b) => 58 | (a -> Result.Result b) -> String -> a -> Result.Result b 59 | transformNotes transform = transformWithCheck transform assert 60 | where assert code code' = getCode code == getCode code' 61 | 62 | transformWithCheck :: 63 | (a -> Result.Result b) -> 64 | (a -> b -> Bool) -> String -> a -> Result.Result b 65 | transformWithCheck transform assert errorMessage input 66 | = do output <- transform input 67 | if assert input output then return output else 68 | Result.fatalAssertionError errorMessage 69 | 70 | checkedFormatComments :: 71 | Formatter -> 72 | Code.LocatableCommentableCode -> 73 | Result.Result Code.LocatableCommentableCode 74 | checkedFormatComments formatter = transformWithCheck transform assert message 75 | where transform = formatComments formatter 76 | assert = Function.on (==) Code.dropComments 77 | message = "Formatting the comments changed more than just the comments." 78 | 79 | checkedDetachComments :: 80 | Formatter -> 81 | Code.LocatableCommentableCode -> 82 | Result.Result ExactCode.ExactCode 83 | checkedDetachComments formatter 84 | = transformNotes (detachComments formatter) message 85 | where message = "Detaching the comments changed the code itself." 86 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/LineTool.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Working with lines of code 3 | -} 4 | module Language.Haskell.Formatter.Process.LineTool 5 | (Shifter, Shift, countEmptyLines, createShifter, shiftCode) where 6 | import qualified Data.Map.Strict as Map 7 | import qualified Language.Haskell.Formatter.Location as Location 8 | import qualified Language.Haskell.Formatter.Process.Code as Code 9 | 10 | newtype Shifter = Shifter (Map.Map Location.Line Shift) 11 | deriving (Eq, Ord, Show) 12 | 13 | type Shift = Int 14 | 15 | countEmptyLines :: Location.Line -> Location.Line -> Int 16 | countEmptyLines endLine startLine = pred lineDifference 17 | where lineDifference = Location.minus startLine endLine 18 | 19 | createShifter :: Map.Map Location.Line Shift -> Shifter 20 | createShifter relativeShifter = Shifter absoluteShifter 21 | where (_, absoluteShifter) = Map.mapAccum accumulate noShift relativeShifter 22 | accumulate absoluteShift relativeShift 23 | = (absoluteShift', absoluteShift') 24 | where absoluteShift' = absoluteShift + relativeShift 25 | 26 | noShift :: Shift 27 | noShift = 0 28 | 29 | shiftCode :: Shifter -> Code.LocatableCode -> Code.LocatableCode 30 | shiftCode shifter = fmap $ shiftNestedPortion shifter 31 | where shiftNestedPortion = Location.replaceNestedPortionLines . shiftLine 32 | 33 | shiftLine :: Shifter -> Location.Line -> Location.Line 34 | shiftLine shifter line = Location.plus shift line 35 | where shift = lookupShift line shifter 36 | 37 | lookupShift :: Location.Line -> Shifter -> Shift 38 | lookupShift line (Shifter shifter) 39 | = case Map.lookupLE line shifter of 40 | Nothing -> noShift 41 | Just (_, shift) -> shift 42 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Process/Note.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Annotations of syntax trees 3 | -} 4 | module Language.Haskell.Formatter.Process.Note 5 | (CommentNote, commentsBefore, commentsAfter, CommentBox(..), 6 | IndentedComment, commentCore, commentStartColumn, LocationCommentNote, 7 | locationNote, commentNote, createCommentNote, createIndentedComment, 8 | createLocationCommentNote, replaceCommentBoxes, 9 | replaceCommentStartColumn, replaceCommentNote) 10 | where 11 | import qualified Data.Function as Function 12 | import qualified Data.Monoid as Monoid 13 | import qualified Data.Semigroup as Semigroup 14 | import qualified Language.Haskell.Formatter.CommentCore as CommentCore 15 | import qualified Language.Haskell.Formatter.Location as Location 16 | 17 | data CommentNote = CommentNote{commentsBefore :: [CommentBox], 18 | commentsAfter :: [CommentBox]} 19 | deriving (Eq, Ord, Show) 20 | 21 | data CommentBox = ActualComment IndentedComment 22 | | EmptyLine 23 | deriving (Eq, Ord, Show) 24 | 25 | data IndentedComment = IndentedComment{commentCore :: CommentCore.CommentCore, 26 | commentStartColumn :: Location.Column} 27 | deriving (Eq, Ord, Show) 28 | 29 | data LocationCommentNote = LocationCommentNote{locationNote :: 30 | Location.SrcSpanInfo, 31 | commentNote :: CommentNote} 32 | deriving (Eq, Ord, Show) 33 | 34 | instance Semigroup.Semigroup CommentNote where 35 | left <> right = createCommentNote before after 36 | where before = merge commentsBefore 37 | merge getComments = Function.on (++) getComments left right 38 | after = merge commentsAfter 39 | 40 | instance Monoid.Monoid CommentNote where 41 | mempty = createCommentNote [] [] 42 | 43 | instance Location.Portioned LocationCommentNote where 44 | getPortion = Location.getPortion . locationNote 45 | 46 | createCommentNote :: [CommentBox] -> [CommentBox] -> CommentNote 47 | createCommentNote rawCommentsBefore rawCommentsAfter 48 | = CommentNote{commentsBefore = rawCommentsBefore, 49 | commentsAfter = rawCommentsAfter} 50 | 51 | createIndentedComment :: 52 | CommentCore.CommentCore -> 53 | Location.Column -> IndentedComment 54 | createIndentedComment rawCommentCore rawCommentStartColumn 55 | = IndentedComment{commentCore = rawCommentCore, 56 | commentStartColumn = rawCommentStartColumn} 57 | 58 | createLocationCommentNote :: 59 | Location.SrcSpanInfo -> 60 | CommentNote -> LocationCommentNote 61 | createLocationCommentNote rawLocationNote rawCommentNote 62 | = LocationCommentNote{locationNote = rawLocationNote, 63 | commentNote = rawCommentNote} 64 | 65 | replaceCommentBoxes :: 66 | ([CommentBox] -> [CommentBox]) -> CommentNote -> CommentNote 67 | replaceCommentBoxes function note 68 | = note{commentsBefore = replace commentsBefore, 69 | commentsAfter = replace commentsAfter} 70 | where replace getComments = function $ getComments note 71 | 72 | replaceCommentBox :: (CommentBox -> CommentBox) -> CommentNote -> CommentNote 73 | replaceCommentBox function = replaceCommentBoxes $ fmap function 74 | 75 | replaceIndentedComment :: 76 | (IndentedComment -> IndentedComment) -> 77 | CommentNote -> CommentNote 78 | replaceIndentedComment function = replaceCommentBox partFunction 79 | where partFunction (ActualComment comment) = ActualComment $ function comment 80 | partFunction EmptyLine = EmptyLine 81 | 82 | replaceCommentStartColumn :: 83 | (Location.Column -> Location.Column) -> 84 | CommentNote -> CommentNote 85 | replaceCommentStartColumn function = replaceIndentedComment partFunction 86 | where partFunction comment 87 | = comment{commentStartColumn = function $ commentStartColumn comment} 88 | 89 | replaceCommentNote :: 90 | (CommentNote -> CommentNote) -> 91 | LocationCommentNote -> LocationCommentNote 92 | replaceCommentNote function note 93 | = note{commentNote = function $ commentNote note} 94 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Result.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Result with possible errors 3 | -} 4 | module Language.Haskell.Formatter.Result 5 | (Result, toEither, fatalError, fatalAssertionError) where 6 | import qualified Control.Applicative as Applicative 7 | import qualified Control.Monad as Monad 8 | import qualified Language.Haskell.Formatter.Error as Error 9 | 10 | newtype Result a = Result (Either Error.Error a) 11 | deriving (Eq, Ord, Show) 12 | 13 | instance Functor Result where 14 | fmap = Monad.liftM 15 | 16 | instance Applicative.Applicative Result where 17 | pure = return 18 | (<*>) = Monad.ap 19 | 20 | instance Monad Result where 21 | return = Result . return 22 | Result result >>= action = Result $ result >>= toEither . action 23 | 24 | toEither :: Result a -> Either Error.Error a 25 | toEither (Result result) = result 26 | 27 | fatalError :: Error.Error -> Result a 28 | fatalError = Result . Left 29 | 30 | fatalAssertionError :: String -> Result a 31 | fatalAssertionError = fatalError . Error.createAssertionError 32 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Source.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Facade for HSE without location handling 3 | 4 | See also "Language.Haskell.Formatter.Location". 5 | -} 6 | module Language.Haskell.Formatter.Source 7 | (Comments.Comment, ExactPrint.exactPrint, Exts.parseFileContents, 8 | Exts.parseFileContentsWithComments, Parser.defaultParseMode, 9 | Parser.parseFilename, Parser.ParseResult(..), 10 | module Language.Haskell.Exts.Pretty, (Syntax.=~=), Syntax.Module, 11 | createComment, commentCore) 12 | where 13 | import qualified Language.Haskell.Exts as Exts 14 | import qualified Language.Haskell.Exts.Comments as Comments 15 | import qualified Language.Haskell.Exts.ExactPrint as ExactPrint 16 | import qualified Language.Haskell.Exts.Parser as Parser 17 | import Language.Haskell.Exts.Pretty 18 | import qualified Language.Haskell.Exts.Syntax as Syntax 19 | import qualified Language.Haskell.Formatter.CommentCore as CommentCore 20 | import qualified Language.Haskell.Formatter.Location as Location 21 | 22 | createComment :: CommentCore.CommentCore -> Location.SrcSpan -> Comments.Comment 23 | createComment core portion = Comments.Comment isMultiLine portion content 24 | where isMultiLine 25 | = case CommentCore.kind core of 26 | CommentCore.Ordinary -> False 27 | CommentCore.Nested -> True 28 | content = CommentCore.content core 29 | 30 | commentCore :: Comments.Comment -> CommentCore.CommentCore 31 | commentCore comment = CommentCore.create kind content 32 | where kind = commentKind comment 33 | content = commentContent comment 34 | 35 | commentKind :: Comments.Comment -> CommentCore.Kind 36 | commentKind (Comments.Comment False _ _) = CommentCore.Ordinary 37 | commentKind (Comments.Comment True _ _) = CommentCore.Nested 38 | 39 | commentContent :: Comments.Comment -> String 40 | commentContent (Comments.Comment _ _ content) = content 41 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Style.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Parametrization of formatting 3 | -} 4 | module Language.Haskell.Formatter.Style 5 | (Style, lineLengthLimit, ribbonsPerLine, successiveEmptyLinesLimit, 6 | classIndentation, doIndentation, caseIndentation, letIndentation, 7 | whereIndentation, onsideIndentation, orderImportDeclarations, 8 | orderImportEntities, Indentation, defaultStyle, check) 9 | where 10 | import qualified Data.Maybe as Maybe 11 | import qualified Language.Haskell.Formatter.Error as Error 12 | import qualified Language.Haskell.Formatter.Internal.Newline as Newline 13 | import qualified Language.Haskell.Formatter.Result as Result 14 | import qualified Language.Haskell.Formatter.Source as Source 15 | 16 | data Style = Style{lineLengthLimit :: Int, ribbonsPerLine :: Float, 17 | successiveEmptyLinesLimit :: Int, 18 | classIndentation :: Indentation, 19 | doIndentation :: Indentation, caseIndentation :: Indentation, 20 | letIndentation :: Indentation, 21 | whereIndentation :: Indentation, 22 | onsideIndentation :: Indentation, 23 | orderImportDeclarations :: Bool, orderImportEntities :: Bool} 24 | deriving (Eq, Ord, Show) 25 | 26 | newtype Check = Check (Maybe String) 27 | deriving (Eq, Ord, Show) 28 | 29 | {-| Number of characters used to indent. -} 30 | type Indentation = Int 31 | 32 | defaultStyle :: Style 33 | defaultStyle 34 | = Style{lineLengthLimit = 80, ribbonsPerLine = 1, 35 | successiveEmptyLinesLimit = 1, 36 | classIndentation = Source.classIndent mode, 37 | doIndentation = Source.doIndent mode, 38 | caseIndentation = Source.caseIndent mode, 39 | letIndentation = Source.letIndent mode, 40 | whereIndentation = Source.whereIndent mode, 41 | onsideIndentation = Source.onsideIndent mode, 42 | orderImportDeclarations = True, orderImportEntities = True} 43 | where mode = Source.defaultMode 44 | 45 | check :: Style -> Result.Result () 46 | check style 47 | = case maybeError of 48 | Nothing -> return () 49 | Just message -> Result.fatalError $ Error.createStyleFormatError message 50 | where maybeError 51 | = case errorMessages of 52 | [] -> Nothing 53 | messages -> Just $ Newline.joinSeparatedLines messages 54 | errorMessages = Maybe.mapMaybe unwrap $ createChecks style 55 | unwrap (Check errorMessage) = errorMessage 56 | 57 | createChecks :: Style -> [Check] 58 | createChecks style 59 | = concat 60 | [[lineLengthLimitCheck, ribbonsPerLineCheck, 61 | successiveEmptyLinesLimitCheck], 62 | indentationChecks, [onsideLessCheck]] 63 | where lineLengthLimitCheck 64 | = createCheck (rawLineLengthLimit > 0) 65 | ["The line length limit must be positive, but it is ", 66 | show rawLineLengthLimit, "."] 67 | rawLineLengthLimit = lineLengthLimit style 68 | ribbonsPerLineCheck 69 | = createCheck (rawRibbonsPerLine >= 1) 70 | ["The ribbons per line ratio must be at least 1, but it is ", 71 | show rawRibbonsPerLine, "."] 72 | rawRibbonsPerLine = ribbonsPerLine style 73 | successiveEmptyLinesLimitCheck 74 | = createCheck (rawSuccessiveEmptyLinesLimit >= 0) 75 | ["The successive empty lines limit must not be negative, ", 76 | "but it is ", show rawSuccessiveEmptyLinesLimit, "."] 77 | rawSuccessiveEmptyLinesLimit = successiveEmptyLinesLimit style 78 | 79 | indentationChecks = fmap checkIndentation indentations 80 | checkIndentation (indentation, name) 81 | = createCheck (indentation > 0) 82 | ["The ", name, " indentation must be positive, but it is ", 83 | show indentation, "."] 84 | indentations 85 | = [(rawClassIndentation, "class"), (rawDoIndentation, "do"), 86 | (rawCaseIndentation, "case"), (rawLetIndentation, "let"), 87 | (rawWhereIndentation, "where"), (rawOnsideIndentation, onsideName)] 88 | rawClassIndentation = classIndentation style 89 | rawDoIndentation = doIndentation style 90 | rawCaseIndentation = caseIndentation style 91 | rawLetIndentation = letIndentation style 92 | rawWhereIndentation = whereIndentation style 93 | rawOnsideIndentation = onsideIndentation style 94 | onsideName = "onside" 95 | onsideLessCheck 96 | = createCheck 97 | (and $ fmap (> rawOnsideIndentation) greaterOnsideIndentations) 98 | ["The ", onsideName, 99 | " indentation must be less than the other indentations, ", 100 | "but it is ", show rawOnsideIndentation, "."] 101 | greaterOnsideIndentations 102 | = [rawClassIndentation, rawDoIndentation, rawCaseIndentation, 103 | rawLetIndentation, rawWhereIndentation] 104 | 105 | createCheck :: Bool -> [String] -> Check 106 | createCheck False = Check . Just . concat 107 | createCheck True = const $ Check Nothing 108 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Toolkit/ListTool.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : List utilities 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.ListTool 5 | (maybeLast, dropWhileAtMost, mergeLongerSuccessions, takeEvery, 6 | concatenateRuns, concatenateShiftedRuns) 7 | where 8 | import qualified Data.List as List 9 | import qualified Data.Maybe as Maybe 10 | import qualified Data.Monoid as Monoid 11 | 12 | {-| The last element, or 'Nothing' if there is none. 13 | 14 | prop> maybeLast [] == Nothing 15 | prop> maybeLast (l ++ [e]) == Just e -} 16 | maybeLast :: [a] -> Maybe a 17 | maybeLast = Maybe.listToMaybe . reverse 18 | 19 | {-| @dropWhileAtMost p l@ is like @dropWhile p@, but drops at most @l@ elements. 20 | 21 | >>> dropWhileAtMost (== ' ') 2 " a bc " 22 | " a bc " -} 23 | dropWhileAtMost :: (a -> Bool) -> Int -> [a] -> [a] 24 | dropWhileAtMost predicate limit list 25 | = Monoid.mappend (dropWhile predicate deformable) rigid 26 | where (deformable, rigid) = splitAt limit list 27 | 28 | {-| @mergeLongerSuccessions p c l@ keeps only the first @c@ elements of 29 | successive elements of @l@ satisfying the predicate @p@. 30 | 31 | >>> mergeLongerSuccessions Data.Char.isSpace 2 " ab c d\LF e " 32 | " ab c d\n e " -} 33 | mergeLongerSuccessions :: (a -> Bool) -> Int -> [a] -> [a] 34 | mergeLongerSuccessions predicate count = snd . List.foldl' merge (0, []) 35 | where merge (successionLength, list) element 36 | = if predicate element then 37 | if successionLength < count then (succ successionLength, extended) 38 | else (count, list) 39 | else (0, extended) 40 | where extended = Monoid.mappend list [element] 41 | 42 | {-| @takeEvery p l@ takes every @p@th element of @l@ from the first one. 43 | 44 | >>> takeEvery 2 "apple" 45 | "ape" 46 | 47 | prop> takeEvery 1 l == l -} 48 | takeEvery :: Int -> [a] -> [a] 49 | takeEvery _ [] = [] 50 | takeEvery period list@(first : _) = first : takeEvery period (drop period list) 51 | 52 | {-| @concatenateRuns p l@ repeatedly concatenates @p@ lists of @l@. 53 | 54 | >>> concatenateRuns 2 ["a", "b", "c", "d", "e"] 55 | ["ab","cd","e"] -} 56 | concatenateRuns :: Int -> [[a]] -> [[a]] 57 | concatenateRuns _ [] = [] 58 | concatenateRuns period lists = concat run : concatenateRuns period rest 59 | where (run, rest) = splitAt period lists 60 | 61 | {-| @concatenateShiftedRuns p s l@ first takes @s@ lists of @l@, followed by 62 | repeatedly concatenating @p@ lists. 63 | 64 | >>> concatenateShiftedRuns 2 1 ["a", "b", "c", "d", "e"] 65 | ["a","bc","de"] 66 | 67 | prop> p <= 0 || concatenateShiftedRuns p 0 l == concatenateRuns p l -} 68 | concatenateShiftedRuns :: Int -> Int -> [[a]] -> [[a]] 69 | concatenateShiftedRuns period shift lists 70 | = case shift of 71 | 0 -> concatenateUnshifted lists 72 | _ -> concat shifted : concatenateUnshifted unshifted 73 | where (shifted, unshifted) = splitAt shift lists 74 | where concatenateUnshifted = concatenateRuns period 75 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Toolkit/Splitter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Splitting lists on sublists 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.Splitter (separate) where 5 | import qualified Control.Applicative as Applicative 6 | import qualified Data.List as List 7 | import qualified Data.Monoid as Monoid 8 | import qualified Language.Haskell.Formatter.Toolkit.ListTool as ListTool 9 | import qualified Language.Haskell.Formatter.Toolkit.Visit as Visit 10 | 11 | {-| Strategy to split a list on sublists. -} 12 | data Splitter a = Splitter{delimiterPolicy :: DelimiterPolicy, 13 | delimiterQueue :: [[a]]} 14 | deriving (Eq, Ord, Show) 15 | 16 | {-| What to do with the delimiters? -} 17 | data DelimiterPolicy = Drop 18 | | Separate 19 | | MergeLeft 20 | | MergeRight 21 | deriving (Eq, Ord, Show) 22 | 23 | {-| @separate d l@ splits @l@ on the delimiters @d@, which are matched in the 24 | given order. The delimiters are not kept. 25 | 26 | >>> separate ["pineapple", "pine"] "0pineapple1" 27 | ["0","1"] 28 | >>> separate ["pine", "pineapple"] "0pineapple1" 29 | ["0","apple1"] -} 30 | separate :: Eq a => [[a]] -> [a] -> [[a]] 31 | separate = split . createSplitter Drop 32 | where createSplitter rawDelimiterPolicy rawDelimiterQueue 33 | = Splitter{delimiterPolicy = rawDelimiterPolicy, 34 | delimiterQueue = rawDelimiterQueue} 35 | 36 | {-| @split s l@ splits @l@ according to the strategy @s@. -} 37 | split :: Eq a => Splitter a -> [a] -> [[a]] 38 | split splitter list 39 | = case delimiterPolicy splitter of 40 | Drop -> ListTool.takeEvery period parts 41 | Separate -> parts 42 | MergeLeft -> ListTool.concatenateRuns period parts 43 | MergeRight -> ListTool.concatenateShiftedRuns period shift parts 44 | where shift = 1 45 | where period = 2 46 | parts = rawSplit (delimiterQueue splitter) list 47 | 48 | {-| @rawSplit s l@ splits @l@ on the sublists @s@, keeping the separators. 49 | 50 | prop> odd . length $ separate ["apple", "pine"] l -} 51 | rawSplit :: Eq a => [[a]] -> [a] -> [[a]] 52 | rawSplit delimiters = move [] [] 53 | where move parts left [] = Monoid.mappend parts [left] 54 | move parts left right@(first : rest) 55 | = case stripFirstPrefix delimiters right of 56 | Nothing -> move parts (Monoid.mappend left [first]) rest 57 | Just (delimiter, suffix) -> move 58 | (Monoid.mappend parts 59 | [left, delimiter]) 60 | [] 61 | suffix 62 | 63 | {-| @stripFirstPrefix p l@ returns the first element of @p@ which is a prefix of 64 | @l@ and the rest of @l@. It returns 'Nothing' if there is no such element. 65 | 66 | >>> stripFirstPrefix ["\LF", "\CR\LF", "\CR"] "\CR\LFpine" 67 | Just ("\r\n","pine") 68 | >>> stripFirstPrefix ["apple"] "pineapple" 69 | Nothing -} 70 | stripFirstPrefix :: Eq a => [[a]] -> [a] -> Maybe ([a], [a]) 71 | stripFirstPrefix prefixes list = Visit.findJust strip prefixes 72 | where strip prefix = (,) prefix Applicative.<$> List.stripPrefix prefix list 73 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Toolkit/StreamName.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Naming data streams 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.StreamName 5 | (StreamName, createStreamName, standardInput) where 6 | 7 | {-| An informal reference to a data stream. For example, this could be the name 8 | of a file stream to be used in error messages. -} 9 | newtype StreamName = StreamName String 10 | deriving (Eq, Ord) 11 | 12 | instance Show StreamName where 13 | show (StreamName string) = string 14 | 15 | {-| Creates a 'StreamName'. 'show' is guaranteed to return this string. 16 | 17 | prop> show (createStreamName s) == s -} 18 | createStreamName :: String -> StreamName 19 | createStreamName = StreamName 20 | 21 | {-| The standard input stream (stdin). -} 22 | standardInput :: StreamName 23 | standardInput = createStreamName "" 24 | -------------------------------------------------------------------------------- /src/library/Language/Haskell/Formatter/Toolkit/Visit.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Container utilities 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.Visit 5 | (findJust, orderByKey, compose, halfZipWith, 6 | mapAccumulateLeftWithCreation) 7 | where 8 | import qualified Data.Foldable as Foldable 9 | import qualified Data.List as List 10 | import qualified Data.Maybe as Maybe 11 | import qualified Data.Monoid as Monoid 12 | import qualified Data.Ord as Ord 13 | import qualified Data.Traversable as Traversable 14 | 15 | {-| @findJust f c@ returns the first non-'Nothing' value of @c@ mapped with @f@, 16 | or 'Nothing' if there is none. -} 17 | findJust :: (Functor t, Foldable.Foldable t) => (a -> Maybe b) -> t a -> Maybe b 18 | findJust function = Foldable.asum . fmap function 19 | 20 | {-| @compose f@ returns the function composition of the elements of @f@. -} 21 | compose :: Foldable.Foldable t => t (a -> a) -> a -> a 22 | compose = Monoid.appEndo . Foldable.foldMap Monoid.Endo 23 | 24 | {-| @orderByKey k l@ orders @l@ by the sort keys generated by @k@. -} 25 | orderByKey :: Ord b => (a -> b) -> [a] -> [a] 26 | orderByKey = List.sortBy . Ord.comparing 27 | 28 | {-| @halfZipWith m b e@ zips the elements of @b@ and @e@ with @m@, using the 29 | structure of @b@. 'Nothing' is returned if and only if @b@ does not have 30 | enough elements. -} 31 | halfZipWith :: 32 | (Traversable.Traversable t, Foldable.Foldable f) => 33 | (a -> b -> c) -> t a -> f b -> Maybe (t c) 34 | halfZipWith merge base extension = Traversable.sequenceA zippedMaybe 35 | where (_, zippedMaybe) = Traversable.mapAccumL process extensionList base 36 | process [] _ = ([], Nothing) 37 | process (extensionElement : list) baseElement 38 | = (list, Just $ merge baseElement extensionElement) 39 | extensionList = Foldable.toList extension 40 | 41 | {-| Like 'Traversable.mapAccumL', but with a function to create the base. -} 42 | mapAccumulateLeftWithCreation :: 43 | Traversable.Traversable t => 44 | (a -> b -> (a, c)) -> 45 | (b -> a) -> t b -> (Maybe a, t c) 46 | mapAccumulateLeftWithCreation process createBase 47 | = Traversable.mapAccumL processMaybe Nothing 48 | where processMaybe maybeBefore element = (Just after, element') 49 | where (after, element') = process before element 50 | before = Maybe.fromMaybe (createBase element) maybeBefore 51 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.0 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /testsuite/resources/examples/default_style.yaml: -------------------------------------------------------------------------------- 1 | # Lines should be no longer than this length in characters. 2 | line_length_limit: 80 3 | 4 | # How much to spread code over multiple lines instead of trying to fill a single 5 | # line. More precisely, this guides the ratio of "line_length_limit" to the 6 | # ribbon length (the number of characters on a line without leading and trailing 7 | # whitespace). Only the lowest value of 1 forces "line_length_limit" to be 8 | # applied strictly. 9 | # Reference: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777 10 | ribbons_per_line: 1 11 | 12 | # More than this number of empty lines in succession are merged. 13 | successive_empty_lines_limit: 1 14 | 15 | # Indentation lengths in characters. 16 | indentations: 17 | class: 8 # "class" and "instance" declarations. 18 | do: 3 # "do" notation. 19 | case: 4 # Body of "case" expressions. 20 | let: 4 # Declarations in "let" expressions. 21 | where: 6 # Declarations in "where" clauses. 22 | onside: 2 # Continuation lines which would otherwise be offside. 23 | 24 | # Decides which parts of the code to sort. 25 | order: 26 | # Sequence of import declarations. 27 | import_declarations: true 28 | 29 | # Entities of import lists. 30 | import_entities: true 31 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/multiple_annotations/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/multiple_annotations/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_after/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- ^comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_after/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- ^comment 1 4 | 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_before/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- |comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_before/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- |comment 1 4 | 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_none/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/after_none/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | -- comment 1 4 | 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_after/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- |comment 0 3 | -- ^comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_after/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- |comment 0 4 | -- ^comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_before/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- |comment 0 3 | -- |comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_before/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- |comment 0 4 | -- |comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_none/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- |comment 0 3 | -- comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/before_none/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- |comment 0 4 | -- comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_after/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- comment 0 3 | -- ^comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_after/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- comment 0 4 | -- ^comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_before/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- comment 0 3 | -- |comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_before/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- comment 0 4 | -- |comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_none/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- comment 0 3 | -- comment 1 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/line_pair/none_none/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- comment 0 4 | -- comment 1 5 | successor :: a 6 | successor = successor 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/after/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment after 3 | successor :: a 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/after/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment after 3 | 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/before/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- |comment before 3 | successor :: a 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/before/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- |comment before 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/none/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- comment 3 | successor :: a 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/depends_on_displacement/single_annotation/single_line/none/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | -- comment 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/end/1/Input.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/end/1/Output.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/end/2/Input.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | 3 | 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/end/2/Output.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/start/1/Input.hs: -------------------------------------------------------------------------------- 1 | 2 | root = root 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/start/1/Output.hs: -------------------------------------------------------------------------------- 1 | 2 | root = root 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/start/2/Input.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | root = root 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/at_bounds_of_file/start/2/Output.hs: -------------------------------------------------------------------------------- 1 | 2 | root = root 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_different_declarations/1/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | 6 | -- |comment 2 7 | successor = successor 8 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_different_declarations/1/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | 6 | -- |comment 2 7 | successor = successor 8 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_different_declarations/2/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | 5 | -- |comment 1 6 | 7 | -- |comment 2 8 | successor = successor 9 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_different_declarations/2/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | 6 | -- |comment 2 7 | successor = successor 8 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/1/Input.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | -- | comment 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/1/Output.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | -- | comment 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/2/Input.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | 4 | -- | comment 5 | commented = commented 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/2/Output.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | -- | comment 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/3/Input.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | 4 | 5 | -- | comment 6 | commented = commented 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_comments_of_same_declaration/3/Output.hs: -------------------------------------------------------------------------------- 1 | -- * heading 2 | 3 | -- | comment 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/after/1/Input.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | 3 | -- ^ comment 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/after/1/Output.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | 3 | -- ^ comment 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/after/2/Input.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | 3 | 4 | -- ^ comment 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/after/2/Output.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | 3 | -- ^ comment 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/before/1/Input.hs: -------------------------------------------------------------------------------- 1 | -- | comment 2 | 3 | commented = commented 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/before/1/Output.hs: -------------------------------------------------------------------------------- 1 | -- | comment 2 | 3 | commented = commented 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/before/2/Input.hs: -------------------------------------------------------------------------------- 1 | -- | comment 2 | 3 | 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_declaration_and_comment/before/2/Output.hs: -------------------------------------------------------------------------------- 1 | -- | comment 2 | 3 | commented = commented 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/0/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | successor :: Bool 3 | successor = successor 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/0/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor :: Bool 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/1/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor :: Bool 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/1/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor :: Bool 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/2/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | 4 | successor :: Bool 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/with_type_signature/2/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor :: Bool 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/0/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | successor = successor 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/0/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | successor = successor 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/1/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor = successor 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/1/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor = successor 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/2/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/empty_lines/between_top_level_functions/without_type_signature/2/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | 3 | successor = successor 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/actual_code_between_start_and_commented/Input.hs: -------------------------------------------------------------------------------- 1 | start 2 | = "sibling" : 3 | -- comment 4 | ["commented"] 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/actual_code_between_start_and_commented/Output.hs: -------------------------------------------------------------------------------- 1 | -- comment 2 | start = "sibling" : ["commented"] 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/basic/Input.hs: -------------------------------------------------------------------------------- 1 | start 2 | -- comment 3 | = "commented" 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/basic/Output.hs: -------------------------------------------------------------------------------- 1 | -- comment 2 | start = "commented" 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/indented_start/Input.hs: -------------------------------------------------------------------------------- 1 | root = start 2 | where start 3 | -- comment 4 | = "commented" 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/inherits_indentation_of_merged_line/indented_start/Output.hs: -------------------------------------------------------------------------------- 1 | root = start 2 | -- comment 3 | where start = "commented" 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/keeps_indentation_with_separate_line/Input.hs: -------------------------------------------------------------------------------- 1 | root 2 | -- comment 3 | = ["commented", "commented", " ", "commented", "commented"] 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/indentation/keeps_indentation_with_separate_line/Output.hs: -------------------------------------------------------------------------------- 1 | root 2 | -- comment 3 | = ["commented", "commented", " ", "commented", "commented"] 4 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/keeps_comments_at_bounds_of_file/end/Input.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/keeps_comments_at_bounds_of_file/end/Output.hs: -------------------------------------------------------------------------------- 1 | commented = commented 2 | -- ^comment 0 3 | 4 | -- |comment 1 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/keeps_comments_at_bounds_of_file/start/Input.hs: -------------------------------------------------------------------------------- 1 | -- ^comment 0 2 | 3 | -- |comment 1 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/keeps_comments_at_bounds_of_file/start/Output.hs: -------------------------------------------------------------------------------- 1 | -- ^comment 0 2 | 3 | -- |comment 1 4 | commented = commented 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/treats_nested_comments/Input.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | {-^ {- inner -} outer -} 3 | successor :: a 4 | successor = successor 5 | -------------------------------------------------------------------------------- /testsuite/resources/source/comments/treats_nested_comments/Output.hs: -------------------------------------------------------------------------------- 1 | predecessor = predecessor 2 | {-^ {- inner -} outer -} 3 | 4 | successor :: a 5 | successor = successor 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_infix_binding/Input.hs: -------------------------------------------------------------------------------- 1 | left `after` right = right ++ left 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_infix_binding/Output.hs: -------------------------------------------------------------------------------- 1 | left `after` right = right ++ left 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_constraints/with/Input.hs: -------------------------------------------------------------------------------- 1 | isFixedPoint :: (Eq a) => (a -> a) -> a -> Bool 2 | isFixedPoint function argument = function argument == argument 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_constraints/with/Output.hs: -------------------------------------------------------------------------------- 1 | isFixedPoint :: (Eq a) => (a -> a) -> a -> Bool 2 | isFixedPoint function argument = function argument == argument 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_constraints/without/Input.hs: -------------------------------------------------------------------------------- 1 | isFixedPoint :: Eq a => (a -> a) -> a -> Bool 2 | isFixedPoint function argument = function argument == argument 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_constraints/without/Output.hs: -------------------------------------------------------------------------------- 1 | isFixedPoint :: Eq a => (a -> a) -> a -> Bool 2 | isFixedPoint function argument = function argument == argument 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_inheritance/with/Input.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | class (Monoid a) => Group a where 4 | 5 | inverse :: a -> a 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_inheritance/with/Output.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | class (Monoid a) => Group a where 4 | 5 | inverse :: a -> a 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_inheritance/without/Input.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | class Monoid a => Group a where 4 | 5 | inverse :: a -> a 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/class_inheritance/without/Output.hs: -------------------------------------------------------------------------------- 1 | import Data.Monoid 2 | 3 | class Monoid a => Group a where 4 | 5 | inverse :: a -> a 6 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/instances/with/Input.hs: -------------------------------------------------------------------------------- 1 | class Sized a where 2 | 3 | size :: a -> Int 4 | 5 | instance (Sized a) => Sized [a] where 6 | size = sum . fmap size 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/instances/with/Output.hs: -------------------------------------------------------------------------------- 1 | class Sized a where 2 | 3 | size :: a -> Int 4 | 5 | instance (Sized a) => Sized [a] where 6 | size = sum . fmap size 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/instances/without/Input.hs: -------------------------------------------------------------------------------- 1 | class Sized a where 2 | 3 | size :: a -> Int 4 | 5 | instance Sized a => Sized [a] where 6 | size = sum . fmap size 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_optional_parentheses/instances/without/Output.hs: -------------------------------------------------------------------------------- 1 | class Sized a where 2 | 3 | size :: a -> Int 4 | 5 | instance Sized a => Sized [a] where 6 | size = sum . fmap size 7 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_options_ghc_pragma/Input.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/handles_options_ghc_pragma/Output.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/literals/does_not_escape_characters/Input.hs: -------------------------------------------------------------------------------- 1 | string = "# ¬ 水 😴" 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/literals/does_not_escape_characters/Output.hs: -------------------------------------------------------------------------------- 1 | string = "# ¬ 水 😴" 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_declarations/Input.hs: -------------------------------------------------------------------------------- 1 | import Tree 2 | import qualified Fringe 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_declarations/Output.hs: -------------------------------------------------------------------------------- 1 | import qualified Fringe 2 | import Tree 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_declarations_and_entities/Input.hs: -------------------------------------------------------------------------------- 1 | import Tree (Tree(Leaf, Branch), isLeaf, fringe) 2 | import qualified Fringe (fringe) 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_declarations_and_entities/Output.hs: -------------------------------------------------------------------------------- 1 | import qualified Fringe (fringe) 2 | import Tree (Tree(Branch, Leaf), fringe, isLeaf) 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_entities_before_declarations/Input.hs: -------------------------------------------------------------------------------- 1 | import Module (b, d) 2 | import Module (c, a) 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/import_entities_before_declarations/Output.hs: -------------------------------------------------------------------------------- 1 | import Module (a, c) 2 | import Module (b, d) 3 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/nested_import_entities/Input.hs: -------------------------------------------------------------------------------- 1 | import Tree (Tree(Leaf, Branch)) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/nested_import_entities/Output.hs: -------------------------------------------------------------------------------- 1 | import Tree (Tree(Branch, Leaf)) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/nested_import_entities_before_root_entities/Input.hs: -------------------------------------------------------------------------------- 1 | import Module (Root(b, d), Root(c, a)) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/nested_import_entities_before_root_entities/Output.hs: -------------------------------------------------------------------------------- 1 | import Module (Root(a, c), Root(b, d)) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/root_import_entities/Input.hs: -------------------------------------------------------------------------------- 1 | import Tree (isLeaf, fringe) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/orders_parts/root_import_entities/Output.hs: -------------------------------------------------------------------------------- 1 | import Tree (fringe, isLeaf) 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/terminates_file_with_newline/Input.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | -------------------------------------------------------------------------------- /testsuite/resources/source/terminates_file_with_newline/Output.hs: -------------------------------------------------------------------------------- 1 | root = root 2 | -------------------------------------------------------------------------------- /testsuite/src/Language/Haskell/Formatter/Internal/Tests.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Tests for internal parts 3 | -} 4 | module Language.Haskell.Formatter.Internal.Tests (tests) where 5 | import qualified Data.List as List 6 | import qualified Language.Haskell.Formatter as Formatter 7 | import qualified Language.Haskell.Formatter.Internal.StyleFileFormat 8 | as StyleFileFormat 9 | import qualified Language.Haskell.Formatter.Internal.TreeFormat as TreeFormat 10 | import qualified System.FilePath as FilePath 11 | import qualified Test.Tasty as Tasty 12 | import qualified Test.Tasty.HUnit as HUnit 13 | 14 | tests :: IO Tasty.TestTree 15 | tests = return testDefaultStyleFile 16 | 17 | testDefaultStyleFile :: Tasty.TestTree 18 | testDefaultStyleFile = Tasty.testGroup name defaultStyleFileTests 19 | where name = "Default style file" 20 | defaultStyleFileTests 21 | = [testDefaultStyleFileUsesDefaults, 22 | testReadmeContainsDefaultStyleFile] 23 | 24 | testDefaultStyleFileUsesDefaults :: Tasty.TestTree 25 | testDefaultStyleFileUsesDefaults = HUnit.testCase name assertion 26 | where name = "Uses defaults" 27 | assertion 28 | = do maybeStyle <- getStyle 29 | case maybeStyle of 30 | Left errorMessage -> HUnit.assertFailure errorMessage 31 | Right style -> style HUnit.@?= defaultStyle 32 | getStyle 33 | = TreeFormat.parseYamlFile StyleFileFormat.treeFormat defaultStyle 34 | defaultStyleFile 35 | defaultStyle 36 | = Formatter.configurationStyle Formatter.defaultConfiguration 37 | 38 | defaultStyleFile :: FilePath 39 | defaultStyleFile 40 | = "testsuite" FilePath. "resources" FilePath. "examples" FilePath. 41 | "default_style.yaml" 42 | 43 | testReadmeContainsDefaultStyleFile :: Tasty.TestTree 44 | testReadmeContainsDefaultStyleFile = HUnit.testCase name assertion 45 | where name = "Is contained in readme" 46 | assertion 47 | = do styleString <- readFile defaultStyleFile 48 | readme <- readFile readmeFile 49 | let isContained = styleString `List.isInfixOf` readme 50 | HUnit.assertBool message isContained 51 | readmeFile = "README.md" 52 | message 53 | = concat 54 | [show readmeFile, " must contain ", show defaultStyleFile, 55 | ", but it does not."] 56 | -------------------------------------------------------------------------------- /testsuite/src/Language/Haskell/Formatter/Tests.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Tests for formatting based on source code files 3 | -} 4 | module Language.Haskell.Formatter.Tests (tests) where 5 | import qualified Control.Applicative as Applicative 6 | import qualified Control.Exception as Exception 7 | import qualified Data.Map.Strict as Map 8 | import qualified Data.Set as Set 9 | import qualified Language.Haskell.Formatter as Formatter 10 | import qualified Language.Haskell.Formatter.Toolkit.FileTesting as FileTesting 11 | import qualified Language.Haskell.Formatter.Toolkit.TestTool as TestTool 12 | import qualified System.FilePath as FilePath 13 | import qualified Test.Tasty as Tasty 14 | import qualified Test.Tasty.HUnit as HUnit 15 | 16 | tests :: IO Tasty.TestTree 17 | tests 18 | = Tasty.testGroup name Applicative.<$> FileTesting.fileTestForest create root 19 | where name = "Formatting files" 20 | root = "testsuite" FilePath. "resources" FilePath. "source" 21 | 22 | create :: 23 | Either Exception.IOException (Map.Map FilePath String) -> 24 | [Tasty.TestTree] 25 | create (Left exception) = [TestTool.testingError name $ show exception] 26 | where name = "I/O exception" 27 | create (Right testMap) 28 | = if actualKeys == expectedKeys then fileTests input expectedOutput else 29 | [TestTool.testingError name message] 30 | where actualKeys = Map.keysSet testMap 31 | expectedKeys = Set.fromList [inputKey, outputKey] 32 | input = testMap Map.! inputKey 33 | expectedOutput = testMap Map.! outputKey 34 | name = "Set of filenames" 35 | message 36 | = concat 37 | ["The filenames are ", setString actualKeys, " instead of ", 38 | setString expectedKeys, "."] 39 | setString = show . Set.elems 40 | 41 | inputKey :: FilePath 42 | inputKey = "Input.hs" 43 | 44 | outputKey :: FilePath 45 | outputKey = "Output.hs" 46 | 47 | fileTests :: String -> String -> [Tasty.TestTree] 48 | fileTests input expectedOutput 49 | = [HUnit.testCase "Formatting once" base, 50 | HUnit.testCase "Idempotence" idempotence] 51 | where base = testFormatting inputKey input expectedOutput 52 | idempotence = testFormatting outputKey expectedOutput expectedOutput 53 | 54 | testFormatting :: FilePath -> String -> String -> HUnit.Assertion 55 | testFormatting inputFile input expectedOutput 56 | = case Formatter.format configuration input of 57 | Left unexpectedError -> HUnit.assertFailure $ show unexpectedError 58 | Right actualOutput -> actualOutput HUnit.@?= expectedOutput 59 | where configuration 60 | = Formatter.defaultConfiguration{Formatter.configurationStreamName = 61 | inputStream} 62 | inputStream = Formatter.createStreamName inputFile 63 | -------------------------------------------------------------------------------- /testsuite/src/Language/Haskell/Formatter/Toolkit/FileTesting.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Test data based on file trees 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.FileTesting (fileTestForest) where 5 | import qualified Control.Exception as Exception 6 | import qualified Data.Map.Strict as Map 7 | import qualified Data.Monoid as Monoid 8 | import qualified Language.Haskell.Formatter.Internal.MapTree as MapTree 9 | import qualified Language.Haskell.Formatter.Toolkit.FileTree as FileTree 10 | import qualified Test.Tasty as Tasty 11 | 12 | fileTestForest :: 13 | (Either Exception.IOException (Map.Map FilePath String) -> 14 | [Tasty.TestTree]) 15 | -> FilePath -> IO [Tasty.TestTree] 16 | fileTestForest = folderTestForest readFile 17 | 18 | folderTestForest :: 19 | Monoid.Monoid a => 20 | (FilePath -> IO a) -> 21 | (Either Exception.IOException (Map.Map FilePath a) -> 22 | [Tasty.TestTree]) 23 | -> FilePath -> IO [Tasty.TestTree] 24 | folderTestForest create createTests rootFolder 25 | = do fileForest <- FileTree.collectFiles create rootFolder 26 | return . createTestForest $ MapTree.summarizeLeaves fileForest 27 | where createTestForest = testForest createTests 28 | 29 | testForest :: 30 | (a -> [Tasty.TestTree]) -> 31 | MapTree.MapTree Tasty.TestName a -> [Tasty.TestTree] 32 | testForest createTests (MapTree.Leaf value) = createTests value 33 | testForest createTests (MapTree.Node forest) 34 | = Map.elems $ Map.mapWithKey testTree forest 35 | where testTree label = Tasty.testGroup label . testForest createTests 36 | -------------------------------------------------------------------------------- /testsuite/src/Language/Haskell/Formatter/Toolkit/FileTree.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Creating trees from files and folders 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.FileTree (collectFiles) where 5 | import qualified Control.Applicative as Applicative 6 | import qualified Control.Exception as Exception 7 | import qualified Data.Map.Strict as Map 8 | import qualified Language.Haskell.Formatter.Internal.MapTree as MapTree 9 | import qualified System.Directory.Tree as Tree 10 | 11 | collectFiles :: 12 | (FilePath -> IO a) -> 13 | FilePath -> 14 | IO 15 | (MapTree.MapForest FilePath (Either Exception.IOException a)) 16 | collectFiles create rootFolder 17 | = do rawTree <- Tree.dirTree Applicative.<$> 18 | Tree.readDirectoryWith create rootFolder 19 | return $ transformRawTree rawTree 20 | 21 | transformRawTree :: 22 | Tree.DirTree a -> 23 | MapTree.MapForest FilePath (Either Exception.IOException a) 24 | transformRawTree root = transform [root] 25 | where transform = Map.fromList . fmap bind 26 | bind rawTree = (label, tree) 27 | where label = Tree.name rawTree 28 | tree 29 | = case rawTree of 30 | Tree.Failed{Tree.err = exception} -> MapTree.Leaf . Left 31 | $ exception 32 | Tree.File{Tree.file = value} -> MapTree.Leaf $ 33 | Right value 34 | Tree.Dir{Tree.contents = forest} -> MapTree.Node $ 35 | transform forest 36 | -------------------------------------------------------------------------------- /testsuite/src/Language/Haskell/Formatter/Toolkit/TestTool.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Testing utilities 3 | -} 4 | module Language.Haskell.Formatter.Toolkit.TestTool 5 | (testingError, standardSourceCodeTest, documentationTest) where 6 | import qualified Data.List as List 7 | import qualified Data.Monoid as Monoid 8 | import qualified Language.Haskell.HLint as HLint 9 | import qualified Test.DocTest as DocTest 10 | import qualified Test.Tasty as Tasty 11 | import qualified Test.Tasty.HUnit as HUnit 12 | 13 | testingError :: Tasty.TestName -> String -> Tasty.TestTree 14 | testingError name = HUnit.testCase name . HUnit.assertFailure 15 | 16 | standardSourceCodeTest :: FilePath -> Tasty.TestTree 17 | standardSourceCodeTest file = HUnit.testCase file assertion 18 | where assertion = sequence_ assertions 19 | assertions = [lineLengthAssertion file, codeHintAssertion file] 20 | 21 | lineLengthAssertion :: FilePath -> HUnit.Assertion 22 | lineLengthAssertion file = readFile file >>= test 23 | where test string = HUnit.assertBool message $ null indices 24 | where message 25 | = concat 26 | ["The following lines are longer than ", show lengthLimit, 27 | " characters: ", show indices] 28 | indices 29 | = [index | (line, index) <- indexedLines, 30 | length line > lengthLimit] 31 | indexedLines = zip (lines string) [baseLine ..] 32 | lengthLimit = 80 33 | baseLine = 1 :: Integer 34 | 35 | codeHintAssertion :: FilePath -> HUnit.Assertion 36 | codeHintAssertion file 37 | = do errors <- HLint.hlint arguments 38 | HUnit.assertBool (showLines errors) $ null errors 39 | where arguments = [suppressFeedback, file] 40 | suppressFeedback = "--quiet" 41 | showLines = unlines . fmap show 42 | 43 | documentationTest :: [FilePath] -> FilePath -> Tasty.TestTree 44 | documentationTest searchFolders file = HUnit.testCase file assertion 45 | where assertion = DocTest.doctest arguments 46 | arguments = [searchPathAppendix, file] 47 | searchPathAppendix = Monoid.mappend "-i" appendedPaths 48 | appendedPaths 49 | = List.intercalate [pathSeparator] $ fmap escape searchFolders 50 | pathSeparator = ':' 51 | escape = (>>= replace) 52 | replace character = Monoid.mappend prefix [character] 53 | where prefix = ['\\' | character == pathSeparator] 54 | -------------------------------------------------------------------------------- /testsuite/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Root of test suite 3 | -} 4 | module Main (main) where 5 | import qualified Control.Applicative as Applicative 6 | import qualified Data.Set as Set 7 | import qualified Language.Haskell.Formatter.Internal.Tests as Internal 8 | import qualified Language.Haskell.Formatter.Tests as Formatter 9 | import qualified Language.Haskell.Formatter.Toolkit.TestTool as TestTool 10 | import qualified System.FilePath as FilePath 11 | import qualified System.FilePath.Find as Find 12 | import qualified Test.Tasty as Tasty 13 | 14 | main :: IO () 15 | main = sequence tests >>= Tasty.defaultMain . Tasty.testGroup name 16 | where name = "Root" 17 | 18 | tests :: [IO Tasty.TestTree] 19 | tests 20 | = [sourceCodeStandardTests, documentationTests, Formatter.tests, 21 | Internal.tests] 22 | 23 | sourceCodeStandardTests :: IO Tasty.TestTree 24 | sourceCodeStandardTests 25 | = createTestTree TestTool.standardSourceCodeTest Find.always name 26 | where name = "Source code standard" 27 | 28 | createTestTree :: 29 | (FilePath -> Tasty.TestTree) -> 30 | Find.RecursionPredicate -> Tasty.TestName -> IO Tasty.TestTree 31 | createTestTree test recurse rootName 32 | = do files <- concat Applicative.<$> mapM (collectSourceFiles recurse) roots 33 | return . Tasty.testGroup rootName $ fmap test files 34 | 35 | collectSourceFiles :: Find.RecursionPredicate -> FilePath -> IO [FilePath] 36 | collectSourceFiles recurse = Find.find recurse isSourceFile 37 | where isSourceFile = isFile Find.&&? hasSourceExtension 38 | isFile = Find.fileType Find.==? Find.RegularFile 39 | hasSourceExtension = fmap (`Set.member` sourceExtensions) Find.extension 40 | sourceExtensions = Set.fromList [".hs", ".lhs"] 41 | 42 | roots :: [FilePath] 43 | roots 44 | = ["src" FilePath. "library", "src" FilePath. "executable", 45 | "testsuite" FilePath. "src"] 46 | 47 | documentationTests :: IO Tasty.TestTree 48 | documentationTests 49 | = createTestTree (TestTool.documentationTest roots) noRecursion name 50 | where noRecursion = Find.depth Find.==? rootDepth 51 | rootDepth = 0 52 | name = "Documentation (doctest)" 53 | --------------------------------------------------------------------------------