diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -1,171 +1,171 @@ -# stylish-haskell configuration file -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - # Align the right hand side of some elements. This is quite conservative - # and only applies to statements where each element occupies a single - # line. - - simple_align: - cases: true - top_level_patterns: true - records: true - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - file: Like global, but don't add padding when there are no qualified - # imports in the file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: file - - # Folowing options affect only import list alignment. - # - # List align has following options: - # - # - after_alias: Import list is aligned with end of import including - # 'as' and 'hiding' keywords. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - with_alias: Import list is aligned with start of alias or hiding. - # - # > import qualified Data.List as List (concat, foldl, foldr, head, - # > init, last, length) - # - # - new_line: Import list starts always on new line. - # - # > import qualified Data.List as List - # > (concat, foldl, foldr, head, init, last, length) - # - # Default: after_alias - list_align: after_alias - - # Long list align style takes effect when import is too long. This is - # determined by 'columns' setting. - # - # - inline: This option will put as much specs on same line as possible. - # - # - new_line: Import list will start on new line. - # - # - new_line_multiline: Import list will start on new line when it's - # short enough to fit to single line. Otherwise it'll be multiline. - # - # - multiline: One line per import list entry. - # Type with contructor list acts like single import. - # - # > import qualified Data.Map as M - # > ( empty - # > , singleton - # > , ... - # > , delete - # > ) - # - # Default: inline - long_list_align: inline - - # List padding determines indentation of import list on lines after import. - # This option affects 'list_align' and 'long_list_align'. - list_padding: 4 - - # Separate lists option affects formating of import list for type - # or class. The only difference is single space between type and list - # of constructors, selectors and class functions. - # - # - true: There is single space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable (fold, foldl, foldMap)) - # - # - false: There is no space between Foldable type and list of it's - # functions. - # - # > import Data.Foldable (Foldable(fold, foldl, foldMap)) - # - # Default: true - separate_lists: true - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # - compact_line: Similar to compact, but wrap each line with - # `{-#LANGUAGE #-}'. - # - # Default: vertical. - style: vertical - - # Align affects alignment of closing pragma brackets. - # - # - true: Brackets are aligned in same collumn. - # - # - false: Brackets are not aligned together. There is only one space - # between actual import and closing bracket. - # - # Default: true - align: true - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 2 - - # Remove trailing whitespace - - trailing_whitespace: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. Default: 80. -columns: 80 - -# By default, line endings are converted according to the OS. You can override -# preferred format here. -# -# - native: Native newline format. CRLF on Windows, LF on other OSes. -# -# - lf: Convert to LF ("\n"). -# -# - crlf: Convert to CRLF ("\r\n"). -# -# Default: native. -newline: native - -# Sometimes, language extensions are specified in a cabal file or from the -# command line instead of using language pragmas in the file. stylish-haskell -# needs to be aware of these, so it can parse the file correctly. -# -# No language extensions are enabled by default. -# language_extensions: - # - TemplateHaskell - # - QuasiQuotes +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: file + + # Folowing options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with contructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # List padding determines indentation of import list on lines after import. + # This option affects 'list_align' and 'long_list_align'. + list_padding: 4 + + # Separate lists option affects formating of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same collumn. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 2 + + # Remove trailing whitespace + - trailing_whitespace: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,22 +1,22 @@ -The MIT License (MIT) - -Copyright (c) 2014 Daniel Stiner - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. - +The MIT License (MIT) + +Copyright (c) 2014 Daniel Stiner + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,59 +1,59 @@ -hfmt -==== - -[![Hackage](https://img.shields.io/hackage/v/hfmt.svg)](https://hackage.haskell.org/package/hfmt) -[![license](https://img.shields.io/github/license/danstiner/hfmt.svg)](https://github.com/danstiner/hfmt/blob/master/LICENSE) -[![Build Status](https://travis-ci.org/danstiner/hfmt.svg?branch=master)](https://travis-ci.org/danstiner/hfmt) - -hfmt is a tool for formatting Haskell programs. Currently it is simply a gofmt style wrapper of the excellent tools [hlint](https://github.com/ndmitchell/hlint/blob/master/README.md), [hindent](https://github.com/chrisdone/hindent#readme), and [stylish-haskell](https://github.com/jaspervdj/stylish-haskell#readme). - - -## Installation - -with [stack](https://www.haskellstack.org/) - - $ stack install hfmt - -with [cabal](https://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package) - - $ cabal install hfmt - -## Usage - -Check all Haskell source under the current directory: - - hfmt - -Overwrite files with formatting suggestions: - - hfmt -w - -## Help text - - λ hfmt --help - hfmt - format Haskell programs - - Usage: hfmt [-d|--print-diffs] [FILE] - Reformats Haskell source files by applying HLint, hindent, and - stylish-haskell. - - Available options: - -h,--help Show this help text - -d,--print-diffs If a file's formatting is different, print a diff. - -s,--print-sources If a file's formatting is different, print its - source. - -l,--print-paths If a file's formatting is different, print its path. - -w,--write-sources If a file's formatting is different, overwrite it. - FILE Explicit paths to process. - - A single '-' will process standard input. - - Files will be processed directly. - - Directories will be recursively searched for source files to process. - - .cabal files will be parsed and all specified source directories and files processed. - - If no paths are given, the current directory will be searched for .cabal files to process, if none are found the current directory will be recursively searched for source files to process. - - Exit Codes: - 0 = No error - 1 = Encountered I/O or other operational error - 2 = Failed to parse a source code file - 3 = Source code was parsed but cannot be formatted properly - 4 = Formatted code differs from existing source (--print-diffs only) +hfmt +==== + +[![Hackage](https://img.shields.io/hackage/v/hfmt.svg)](https://hackage.haskell.org/package/hfmt) +[![license](https://img.shields.io/github/license/danstiner/hfmt.svg)](https://github.com/danstiner/hfmt/blob/master/LICENSE) +[![Build Status](https://travis-ci.org/danstiner/hfmt.svg?branch=master)](https://travis-ci.org/danstiner/hfmt) + +hfmt is a tool for formatting Haskell programs. Currently it is simply a gofmt style wrapper of the excellent tools [hlint](https://github.com/ndmitchell/hlint/blob/master/README.md), [hindent](https://github.com/chrisdone/hindent#readme), and [stylish-haskell](https://github.com/jaspervdj/stylish-haskell#readme). + + +## Installation + +with [stack](https://www.haskellstack.org/) + + $ stack install hfmt + +with [cabal](https://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package) + + $ cabal install hfmt + +## Usage + +Check all Haskell source under the current directory: + + hfmt + +Overwrite files with formatting suggestions: + + hfmt -w + +## Help text + + λ hfmt --help + hfmt - format Haskell programs + + Usage: hfmt [-d|--print-diffs] [FILE] + Reformats Haskell source files by applying HLint, hindent, and + stylish-haskell. + + Available options: + -h,--help Show this help text + -d,--print-diffs If a file's formatting is different, print a diff. + -s,--print-sources If a file's formatting is different, print its + source. + -l,--print-paths If a file's formatting is different, print its path. + -w,--write-sources If a file's formatting is different, overwrite it. + FILE Explicit paths to process. + - A single '-' will process standard input. + - Files will be processed directly. + - Directories will be recursively searched for source files to process. + - .cabal files will be parsed and all specified source directories and files processed. + - If no paths are given, the current directory will be searched for .cabal files to process, if none are found the current directory will be recursively searched for source files to process. + + Exit Codes: + 0 = No error + 1 = Encountered I/O or other operational error + 2 = Failed to parse a source code file + 3 = Source code was parsed but cannot be formatted properly + 4 = Formatted code differs from existing source (--print-diffs only) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/app/Actions.hs b/app/Actions.hs --- a/app/Actions.hs +++ b/app/Actions.hs @@ -1,41 +1,41 @@ -module Actions - ( act - ) where - -import Language.Haskell.Format -import Language.Haskell.Format.Utilities -import Options -import Types - -import Control.Monad - -act :: Options -> Formatted -> IO Formatted -act options r@(Formatted input source result) = act' (optAction options) - where - act' PrintDiffs = - when wasReformatted' (printDiff input source result) >> return r - act' PrintSources = do - when wasReformatted' (printSource $ reformattedSource result) - return (Formatted input (reformattedSource result) result) - act' PrintFilePaths = when wasReformatted' (print input) >> return r - act' WriteSources = do - when wasReformatted' (writeSource input (reformattedSource result)) - return (Formatted input (reformattedSource result) result) - wasReformatted' = wasReformatted source result - -printDiff :: SourceFile -> HaskellSource -> Reformatted -> IO () -printDiff (SourceFilePath path) source reformatted = do - putStrLn (path ++ ":") - mapM_ (putStr . show) (suggestions reformatted) - putStr (showDiff source (reformattedSource reformatted)) -printDiff StdinSource source reformatted = do - mapM_ (putStr . show) (suggestions reformatted) - putStr (showDiff source (reformattedSource reformatted)) - -printSource :: HaskellSource -> IO () -printSource (HaskellSource _ source) = putStr source - -writeSource :: SourceFile -> HaskellSource -> IO () -writeSource (SourceFilePath path) (HaskellSource _ source) = - writeFile path source -writeSource StdinSource (HaskellSource _ source) = putStr source +module Actions + ( act + ) where + +import Language.Haskell.Format +import Language.Haskell.Format.Utilities +import Options +import Types + +import Control.Monad + +act :: Options -> Formatted -> IO Formatted +act options r@(Formatted input source result) = act' (optAction options) + where + act' PrintDiffs = + when wasReformatted' (printDiff input source result) >> return r + act' PrintSources = do + when wasReformatted' (printSource $ reformattedSource result) + return (Formatted input (reformattedSource result) result) + act' PrintFilePaths = when wasReformatted' (print input) >> return r + act' WriteSources = do + when wasReformatted' (writeSource input (reformattedSource result)) + return (Formatted input (reformattedSource result) result) + wasReformatted' = wasReformatted source result + +printDiff :: SourceFile -> HaskellSource -> Reformatted -> IO () +printDiff (SourceFilePath path) source reformatted = do + putStrLn (path ++ ":") + mapM_ (putStr . show) (suggestions reformatted) + putStr (showDiff source (reformattedSource reformatted)) +printDiff StdinSource source reformatted = do + mapM_ (putStr . show) (suggestions reformatted) + putStr (showDiff source (reformattedSource reformatted)) + +printSource :: HaskellSource -> IO () +printSource (HaskellSource _ source) = putStr source + +writeSource :: SourceFile -> HaskellSource -> IO () +writeSource (SourceFilePath path) (HaskellSource _ source) = + writeFile path source +writeSource StdinSource (HaskellSource _ source) = putStr source diff --git a/app/ExitCode.hs b/app/ExitCode.hs --- a/app/ExitCode.hs +++ b/app/ExitCode.hs @@ -1,48 +1,48 @@ -module ExitCode - ( exitCode - , helpDoc - , operationalFailureCode - , sourceParseFailureCode - ) where - -import Types - -import System.Exit -import Text.PrettyPrint.ANSI.Leijen - --- | Decide which exit code to use --- --- Assume if we are printing diffs that we *are* being run in a CI and so --- should exit with failure if any format differences were found. Otherwise --- assume we are being run in a context where non-zero exit indicates --- failure of the tool to operate properly. -exitCode :: Action -> RunResult -> ExitCode -exitCode _ NoDifferences = ExitSuccess -exitCode PrintDiffs HadDifferences = ExitFailure formattedCodeDiffersFailureCode -exitCode _ HadDifferences = ExitSuccess -exitCode _ SourceParseFailure = ExitFailure sourceParseFailureCode -exitCode _ OperationalFailure = ExitFailure operationalFailureCode - -helpDoc :: Doc -helpDoc = - vsep - [ text "Exit Codes:" - , text " 0 = No error" - , text " 1 = Encountered I/O or other operational error" - , text " 2 = Failed to parse a source code file" - , text " 3 = Source code was parsed but cannot be formatted properly" - , text - " 4 = Formatted code differs from existing source (--print-diffs only)" - ] - --- | Encountered I/O or other operational error -operationalFailureCode :: Int -operationalFailureCode = 1 - --- | Failed to parse a source code file -sourceParseFailureCode :: Int -sourceParseFailureCode = 2 - --- | Formatted code differs from existing source code -formattedCodeDiffersFailureCode :: Int -formattedCodeDiffersFailureCode = 4 +module ExitCode + ( exitCode + , helpDoc + , operationalFailureCode + , sourceParseFailureCode + ) where + +import Types + +import System.Exit +import Text.PrettyPrint.ANSI.Leijen + +-- | Decide which exit code to use +-- +-- Assume if we are printing diffs that we *are* being run in a CI and so +-- should exit with failure if any format differences were found. Otherwise +-- assume we are being run in a context where non-zero exit indicates +-- failure of the tool to operate properly. +exitCode :: Action -> RunResult -> ExitCode +exitCode _ NoDifferences = ExitSuccess +exitCode PrintDiffs HadDifferences = ExitFailure formattedCodeDiffersFailureCode +exitCode _ HadDifferences = ExitSuccess +exitCode _ SourceParseFailure = ExitFailure sourceParseFailureCode +exitCode _ OperationalFailure = ExitFailure operationalFailureCode + +helpDoc :: Doc +helpDoc = + vsep + [ text "Exit Codes:" + , text " 0 = No error" + , text " 1 = Encountered I/O or other operational error" + , text " 2 = Failed to parse a source code file" + , text " 3 = Source code was parsed but cannot be formatted properly" + , text + " 4 = Formatted code differs from existing source (--print-diffs only)" + ] + +-- | Encountered I/O or other operational error +operationalFailureCode :: Int +operationalFailureCode = 1 + +-- | Failed to parse a source code file +sourceParseFailureCode :: Int +sourceParseFailureCode = 2 + +-- | Formatted code differs from existing source code +formattedCodeDiffersFailureCode :: Int +formattedCodeDiffersFailureCode = 4 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,76 +1,76 @@ -{-# LANGUAGE Rank2Types #-} - -module Main - ( main - ) where - -import Actions -import ExitCode -import Language.Haskell.Format -import Language.Haskell.Format.Utilities -import Language.Haskell.Source.Enumerator -import Options -import Types - -import Conduit -import Options.Applicative.Extra as OptApp -import System.Directory -import System.Exit -import System.IO - -main :: IO () -main = do - options <- execParser Options.parser - result <- run options - exitWith $ exitCode (optAction options) result - -run :: Options -> IO RunResult -run opt = - runConduit $ - sources opt .| mapMC readSource .| mapMC formatSource .| mapMC doAction .| - foldMapMC toRunResult - where - formatSource source = do - formatter <- defaultFormatter - return $ applyFormatter formatter source - doAction :: FormatResult -> IO FormatResult - doAction = bimapM return (Actions.act opt) - toRunResult :: FormatResult -> IO RunResult - toRunResult (Left err) = do - hPrint stderr (show err) - return SourceParseFailure - toRunResult (Right (Formatted _ source result)) = - if wasReformatted source result - then return HadDifferences - else return NoDifferences - -sources :: Options -> ConduitT () SourceFile IO () -sources opt = lift paths >>= mapM_ sourcesFromPath - where - explicitPaths = optPaths opt - paths = - if null explicitPaths - then do - currentPath <- getCurrentDirectory - return [currentPath] - else return explicitPaths - -sourcesFromPath :: FilePath -> ConduitT () SourceFile IO () -sourcesFromPath "-" = yield StdinSource -sourcesFromPath path = enumeratePath path .| mapC SourceFilePath - -readSource :: SourceFile -> IO SourceFileWithContents -readSource s@(SourceFilePath path) = - SourceFileWithContents s . HaskellSource path <$> readFile path -readSource s@StdinSource = - SourceFileWithContents s . HaskellSource "stdin" <$> getContents - -applyFormatter :: Formatter -> SourceFileWithContents -> FormatResult -applyFormatter (Formatter doFormat) (SourceFileWithContents file contents) = - case doFormat contents of - Left err -> Left (FormatError file err) - Right reformat -> Right (Formatted file contents reformat) - -bimapM :: Monad m => (a -> m c) -> (b -> m d) -> Either a b -> m (Either c d) -bimapM f _ (Left a) = Left <$> f a -bimapM _ g (Right b) = Right <$> g b +{-# LANGUAGE Rank2Types #-} + +module Main + ( main + ) where + +import Actions +import ExitCode +import Language.Haskell.Format +import Language.Haskell.Format.Utilities +import Language.Haskell.Source.Enumerator +import Options +import Types + +import Conduit +import Options.Applicative.Extra as OptApp +import System.Directory +import System.Exit +import System.IO + +main :: IO () +main = do + options <- execParser Options.parser + result <- run options + exitWith $ exitCode (optAction options) result + +run :: Options -> IO RunResult +run opt = + runConduit $ + sources opt .| mapMC readSource .| mapMC formatSource .| mapMC doAction .| + foldMapMC toRunResult + where + formatSource source = do + formatter <- defaultFormatter + return $ applyFormatter formatter source + doAction :: FormatResult -> IO FormatResult + doAction = bimapM return (Actions.act opt) + toRunResult :: FormatResult -> IO RunResult + toRunResult (Left err) = do + hPrint stderr (show err) + return SourceParseFailure + toRunResult (Right (Formatted _ source result)) = + if wasReformatted source result + then return HadDifferences + else return NoDifferences + +sources :: Options -> ConduitT () SourceFile IO () +sources opt = lift paths >>= mapM_ sourcesFromPath + where + explicitPaths = optPaths opt + paths = + if null explicitPaths + then do + currentPath <- getCurrentDirectory + return [currentPath] + else return explicitPaths + +sourcesFromPath :: FilePath -> ConduitT () SourceFile IO () +sourcesFromPath "-" = yield StdinSource +sourcesFromPath path = enumeratePath path .| mapC SourceFilePath + +readSource :: SourceFile -> IO SourceFileWithContents +readSource s@(SourceFilePath path) = + SourceFileWithContents s . HaskellSource path <$> readFile path +readSource s@StdinSource = + SourceFileWithContents s . HaskellSource "stdin" <$> getContents + +applyFormatter :: Formatter -> SourceFileWithContents -> FormatResult +applyFormatter (Formatter doFormat) (SourceFileWithContents file contents) = + case doFormat contents of + Left err -> Left (FormatError file err) + Right reformat -> Right (Formatted file contents reformat) + +bimapM :: Monad m => (a -> m c) -> (b -> m d) -> Either a b -> m (Either c d) +bimapM f _ (Left a) = Left <$> f a +bimapM _ g (Right b) = Right <$> g b diff --git a/app/Options.hs b/app/Options.hs --- a/app/Options.hs +++ b/app/Options.hs @@ -1,83 +1,83 @@ -module Options - ( Options - , optAction - , optPaths - , parser - ) where - -import qualified ExitCode -import Types - -import Control.Applicative -import Data.Monoid -import Options.Applicative.Builder -import Options.Applicative.Common -import Options.Applicative.Extra -import Text.PrettyPrint.ANSI.Leijen as Leijen hiding ((<$>), (<>)) - -data Options = Options - { optPrintDiffs :: Bool - , optPrintSources :: Bool - , optPrintFilePaths :: Bool - , optWriteSources :: Bool - , optPaths :: [FilePath] - } - -optAction :: Options -> Action -optAction options - | optPrintDiffs options = PrintDiffs - | optPrintFilePaths options = PrintFilePaths - | optPrintSources options = PrintSources - | optWriteSources options = WriteSources - | optPaths options == ["-"] = PrintSources - | otherwise = PrintDiffs - -optionParser :: Parser Options -optionParser = - Options <$> - switch - (long "print-diffs" <> short 'd' <> - help "If a file's formatting is different, print a diff.") <*> - switch - (long "print-sources" <> short 's' <> hidden <> - help "If a file's formatting is different, print its source.") <*> - switch - (long "print-paths" <> short 'l' <> hidden <> - help "If a file's formatting is different, print its path.") <*> - switch - (long "write-sources" <> short 'w' <> hidden <> - help "If a file's formatting is different, overwrite it.") <*> - many pathOption - where - pathOption = strArgument (metavar "FILE" <> pathOptionHelp) - pathOptionHelp = - helpDoc $ - Just $ - text "Explicit paths to process." <> line <> - unorderdedList - " - " - [ text "A single '-' will process standard input." - , text "Files will be processed directly." - , text - "Directories will be recursively searched for source files to process." - , text - ".cabal files will be parsed and all specified source directories and files processed." - , text - "If no paths are given, the current directory will be searched for .cabal files to process, if none are found the current directory will be recursively searched for source files to process." - ] - -unorderdedList :: String -> [Doc] -> Doc -unorderdedList prefix = vsep . map ((text prefix <>) . align) - -optionParserInfo :: ParserInfo Options -optionParserInfo = - info - (helper <*> optionParser) - (fullDesc <> header "hfmt - Format Haskell programs" <> - progDesc - "Reformats Haskell source files by applying HLint, hindent, and stylish-haskell." <> - footerDoc (Just ExitCode.helpDoc) <> - failureCode ExitCode.operationalFailureCode) - -parser :: ParserInfo Options -parser = optionParserInfo +module Options + ( Options + , optAction + , optPaths + , parser + ) where + +import qualified ExitCode +import Types + +import Control.Applicative +import Data.Semigroup ((<>)) +import Options.Applicative.Builder +import Options.Applicative.Common +import Options.Applicative.Extra +import Text.PrettyPrint.ANSI.Leijen as Leijen hiding ((<$>), (<>)) + +data Options = Options + { optPrintDiffs :: Bool + , optPrintSources :: Bool + , optPrintFilePaths :: Bool + , optWriteSources :: Bool + , optPaths :: [FilePath] + } + +optAction :: Options -> Action +optAction options + | optPrintDiffs options = PrintDiffs + | optPrintFilePaths options = PrintFilePaths + | optPrintSources options = PrintSources + | optWriteSources options = WriteSources + | optPaths options == ["-"] = PrintSources + | otherwise = PrintDiffs + +optionParser :: Parser Options +optionParser = + Options <$> + switch + (long "print-diffs" <> short 'd' <> + help "If a file's formatting is different, print a diff.") <*> + switch + (long "print-sources" <> short 's' <> hidden <> + help "If a file's formatting is different, print its source.") <*> + switch + (long "print-paths" <> short 'l' <> hidden <> + help "If a file's formatting is different, print its path.") <*> + switch + (long "write-sources" <> short 'w' <> hidden <> + help "If a file's formatting is different, overwrite it.") <*> + many pathOption + where + pathOption = strArgument (metavar "FILE" <> pathOptionHelp) + pathOptionHelp = + helpDoc $ + Just $ + text "Explicit paths to process." <> line <> + unorderdedList + " - " + [ text "A single '-' will process standard input." + , text "Files will be processed directly." + , text + "Directories will be recursively searched for source files to process." + , text + ".cabal files will be parsed and all specified source directories and files processed." + , text + "If no paths are given, the current directory will be searched for .cabal files to process, if none are found the current directory will be recursively searched for source files to process." + ] + +unorderdedList :: String -> [Doc] -> Doc +unorderdedList prefix = vsep . map ((text prefix <>) . align) + +optionParserInfo :: ParserInfo Options +optionParserInfo = + info + (helper <*> optionParser) + (fullDesc <> header "hfmt - Format Haskell programs" <> + progDesc + "Reformats Haskell source files by applying HLint, hindent, and stylish-haskell." <> + footerDoc (Just ExitCode.helpDoc) <> + failureCode ExitCode.operationalFailureCode) + +parser :: ParserInfo Options +parser = optionParserInfo diff --git a/app/Types.hs b/app/Types.hs --- a/app/Types.hs +++ b/app/Types.hs @@ -1,60 +1,64 @@ -module Types - ( Action(..) - , FormatResult - , FormatError(..) - , Formatted(..) - , HaskellSource(..) - , RunResult(..) - , SourceFile(..) - , SourceFileWithContents(..) - ) where - -import Language.Haskell.Format - -data Action - = PrintDiffs - | PrintSources - | PrintFilePaths - | WriteSources - deriving (Eq) - -data SourceFile - = SourceFilePath FilePath - | StdinSource - -instance Show SourceFile where - show (SourceFilePath path) = path - show StdinSource = "-" - -data SourceFileWithContents = - SourceFileWithContents SourceFile - HaskellSource - -type FormatResult = Either FormatError Formatted - -data FormatError = - FormatError SourceFile - String - -instance Show FormatError where - show (FormatError input errorString) = - "Error reformatting " ++ show input ++ ": " ++ errorString - -data Formatted = - Formatted SourceFile - HaskellSource - Reformatted - -data RunResult - = OperationalFailure - | SourceParseFailure - | HadDifferences - | NoDifferences - -instance Monoid RunResult where - mempty = NoDifferences - x `mappend` NoDifferences = x - NoDifferences `mappend` x = x - OperationalFailure `mappend` _ = OperationalFailure - SourceParseFailure `mappend` _ = SourceParseFailure - HadDifferences `mappend` _ = HadDifferences +module Types + ( Action(..) + , FormatResult + , FormatError(..) + , Formatted(..) + , HaskellSource(..) + , RunResult(..) + , SourceFile(..) + , SourceFileWithContents(..) + ) where + +import Data.Semigroup (Semigroup, (<>)) +import Language.Haskell.Format + +data Action + = PrintDiffs + | PrintSources + | PrintFilePaths + | WriteSources + deriving (Eq) + +data SourceFile + = SourceFilePath FilePath + | StdinSource + +instance Show SourceFile where + show (SourceFilePath path) = path + show StdinSource = "-" + +data SourceFileWithContents = + SourceFileWithContents SourceFile + HaskellSource + +type FormatResult = Either FormatError Formatted + +data FormatError = + FormatError SourceFile + String + +instance Show FormatError where + show (FormatError input errorString) = + "Error reformatting " ++ show input ++ ": " ++ errorString + +data Formatted = + Formatted SourceFile + HaskellSource + Reformatted + +data RunResult + = OperationalFailure + | SourceParseFailure + | HadDifferences + | NoDifferences + +instance Semigroup RunResult where + x <> NoDifferences = x + NoDifferences <> x = x + OperationalFailure <> _ = OperationalFailure + SourceParseFailure <> _ = SourceParseFailure + HadDifferences <> _ = HadDifferences + +instance Monoid RunResult where + mempty = NoDifferences + mappend = (<>) diff --git a/hfmt.cabal b/hfmt.cabal --- a/hfmt.cabal +++ b/hfmt.cabal @@ -1,89 +1,89 @@ -name: hfmt -version: 0.2.2 -synopsis: Haskell source code formatter -description: Inspired by gofmt. Built using hlint, hindent, and stylish-haskell. -license: MIT -license-file: LICENSE -author: Daniel Stiner -maintainer: Daniel Stiner -stability: Experimental -homepage: http://github.com/danstiner/hfmt -bug-reports: http://github.com/danstiner/hfmt/issues -category: Language -build-type: Simple -extra-source-files: README.md, .stylish-haskell.yaml -cabal-version: >=1.9.2 -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.5 - -library - Hs-Source-Dirs: src - Exposed-Modules: Language.Haskell.Format - , Language.Haskell.Format.Utilities - , Language.Haskell.Source.Enumerator - Other-Modules: Language.Haskell.Format.Internal - , Language.Haskell.Format.HIndent - , Language.Haskell.Format.HLint - , Language.Haskell.Format.Stylish - , Language.Haskell.Format.Types - , Path.Find - GHC-Options: -Wall - Build-Depends: base >= 4.8 && < 5 - , bytestring - , Cabal - , conduit - , conduit-combinators - , Diff - , directory - , exceptions - , filepath - , haskell-src-exts > 1.20 - , hindent == 5.* - , hlint == 2.* - , HUnit - , path - , path-io - , pretty - , stylish-haskell == 0.9.* - , text - , transformers - , yaml - -executable hfmt - Hs-Source-Dirs: app - Main-Is: Main.hs - Other-Modules: Actions - , ExitCode - , Options - , Types - GHC-Options: -Wall - Build-Depends: base >= 4.8 && < 5 - , conduit - , conduit-combinators - , directory - , hfmt - , ansi-wl-pprint - , optparse-applicative - -test-suite self-formatting-test - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: test/self-formatting - Main-Is: Spec.hs - Build-Depends: base == 4.* - , hfmt - , HUnit - , test-framework - , test-framework-hunit - -test-suite pure-test - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: test/pure - Main-Is: Spec.hs - Build-Depends: base == 4.* - , hfmt - , HUnit - , test-framework - , test-framework-hunit - -source-repository head - type: git - location: git://github.com:danstiner/hfmt.git +name: hfmt +version: 0.2.3.0 +synopsis: Haskell source code formatter +description: Inspired by gofmt. Built using hlint, hindent, and stylish-haskell. +license: MIT +license-file: LICENSE +author: Daniel Stiner +maintainer: Daniel Stiner +stability: Experimental +homepage: http://github.com/danstiner/hfmt +bug-reports: http://github.com/danstiner/hfmt/issues +category: Language +build-type: Simple +extra-source-files: README.md, .stylish-haskell.yaml +cabal-version: >=1.9.2 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.5 + +library + Hs-Source-Dirs: src + Exposed-Modules: Language.Haskell.Format + , Language.Haskell.Format.Utilities + , Language.Haskell.Source.Enumerator + Other-Modules: Language.Haskell.Format.Internal + , Language.Haskell.Format.HIndent + , Language.Haskell.Format.HLint + , Language.Haskell.Format.Stylish + , Language.Haskell.Format.Types + , Path.Find + GHC-Options: -Wall + Build-Depends: base >= 4.8 && < 5 + , bytestring + , Cabal + , conduit + , conduit-combinators + , Diff + , directory + , exceptions + , filepath + , haskell-src-exts > 1.20 + , hindent == 5.* + , hlint == 2.* + , HUnit + , path + , path-io + , pretty + , stylish-haskell == 0.9.* + , text + , transformers + , yaml + +executable hfmt + Hs-Source-Dirs: app + Main-Is: Main.hs + Other-Modules: Actions + , ExitCode + , Options + , Types + GHC-Options: -Wall + Build-Depends: base >= 4.8 && < 5 + , conduit + , conduit-combinators + , directory + , hfmt + , ansi-wl-pprint + , optparse-applicative + +test-suite self-formatting-test + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: test/self-formatting + Main-Is: Spec.hs + Build-Depends: base == 4.* + , hfmt + , HUnit + , test-framework + , test-framework-hunit + +test-suite pure-test + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: test/pure + Main-Is: Spec.hs + Build-Depends: base == 4.* + , hfmt + , HUnit + , test-framework + , test-framework-hunit + +source-repository head + type: git + location: git://github.com:danstiner/hfmt.git diff --git a/src/Language/Haskell/Format.hs b/src/Language/Haskell/Format.hs --- a/src/Language/Haskell/Format.hs +++ b/src/Language/Haskell/Format.hs @@ -1,39 +1,49 @@ -module Language.Haskell.Format - ( autoSettings - , format - , formatters - , hlint - , hindent - , stylish - , Settings - , Formatter(..) - , Suggestion(..) - , HaskellSource(..) - , Reformatted(..) - ) where - -import qualified Language.Haskell.Format.HIndent as HIndent -import qualified Language.Haskell.Format.HLint as HLint -import qualified Language.Haskell.Format.Stylish as Stylish -import Language.Haskell.Format.Types - -data Settings = - Settings - -autoSettings :: IO Settings -autoSettings = return Settings - -hlint :: Settings -> IO Formatter -hlint _ = HLint.suggester <$> HLint.autoSettings - -hindent :: Settings -> IO Formatter -hindent _ = HIndent.formatter <$> HIndent.autoSettings - -stylish :: Settings -> IO Formatter -stylish _ = Stylish.formatter <$> Stylish.autoSettings - -formatters :: Settings -> IO [Formatter] -formatters s = sequence [hlint s, hindent s, stylish s] - -format :: Formatter -> HaskellSource -> Either String Reformatted -format = unFormatter +module Language.Haskell.Format + ( autoSettings + , format + , formatters + , hlint + , hindent + , stylish + , Settings + , Formatter(..) + , Suggestion(..) + , HaskellSource(..) + , Reformatted(..) + ) where + +import qualified Language.Haskell.Format.HIndent as HIndent +import qualified Language.Haskell.Format.HLint as HLint +import qualified Language.Haskell.Format.Stylish as Stylish +import Language.Haskell.Format.Types + +data Settings = + Settings + +autoSettings :: IO Settings +autoSettings = return Settings + +hlint :: Settings -> IO Formatter +hlint _ = HLint.suggester <$> HLint.autoSettings + +hindent :: Settings -> IO Formatter +hindent _ = HIndent.formatter <$> HIndent.autoSettings + +stylish :: Settings -> IO Formatter +stylish _ = Stylish.formatter <$> Stylish.autoSettings + +errorFor :: String -> Formatter -> Formatter +errorFor name (Formatter formatter) = + Formatter $ \source -> prefixName (formatter source) + where + prefixName (Left err) = Left ("Error in " ++ name ++ ": " ++ err) + prefixName (Right a) = Right a + +formatters :: Settings -> IO [Formatter] +formatters s = traverse (\(name, f) -> fmap (errorFor name) (f s)) named + where + named = + [("hlint", hlint), ("hindent", hindent), ("stylish-haskell", stylish)] + +format :: Formatter -> HaskellSource -> Either String Reformatted +format = unFormatter diff --git a/src/Language/Haskell/Format/HIndent.hs b/src/Language/Haskell/Format/HIndent.hs --- a/src/Language/Haskell/Format/HIndent.hs +++ b/src/Language/Haskell/Format/HIndent.hs @@ -1,62 +1,62 @@ -module Language.Haskell.Format.HIndent - ( autoSettings - , formatter - , defaultFormatter - ) where - -import Data.ByteString.Builder -import Data.ByteString.Lazy as L -import qualified Data.Text as Text -import Data.Text.Encoding as Encoding -import qualified Data.Yaml as Y -import HIndent -import HIndent.Types -import Language.Haskell.Exts.Extension (Extension) -import Path -import qualified Path.Find as Path -import qualified Path.IO as Path - -import Language.Haskell.Format.Internal -import Language.Haskell.Format.Types - -data Settings = - Settings Config - (Maybe [Extension]) - -defaultFormatter :: IO Formatter -defaultFormatter = formatter <$> autoSettings - -autoSettings :: IO Settings -autoSettings = do - config <- getConfig - return $ Settings config $ Just defaultExtensions - --- | Read config from a config file, or return 'defaultConfig'. -getConfig :: IO Config -getConfig = do - cur <- Path.getCurrentDir - homeDir <- Path.getHomeDir - mfile <- - Path.findFileUp - cur - ((== ".hindent.yaml") . toFilePath . filename) - (Just homeDir) - case mfile of - Nothing -> return defaultConfig - Just file -> do - result <- Y.decodeFileEither (toFilePath file) - case result of - Left e -> error (show e) - Right config -> return config - -formatter :: Settings -> Formatter -formatter = mkFormatter . hindent - -hindent :: Settings -> HaskellSource -> Either String HaskellSource -hindent (Settings config extensions) (HaskellSource filepath source) = - HaskellSource filepath . unpackBuilder <$> - reformat config extensions Nothing sourceText - where - sourceText = Encoding.encodeUtf8 . Text.pack $ source - unpackBuilder = - Text.unpack . Encoding.decodeUtf8 . L.toStrict . toLazyByteString +module Language.Haskell.Format.HIndent + ( autoSettings + , formatter + , defaultFormatter + ) where + +import Data.ByteString.Builder +import Data.ByteString.Lazy as L +import qualified Data.Text as Text +import Data.Text.Encoding as Encoding +import qualified Data.Yaml as Y +import HIndent +import HIndent.Types +import Language.Haskell.Exts.Extension (Extension) +import Path +import qualified Path.Find as Path +import qualified Path.IO as Path + +import Language.Haskell.Format.Internal +import Language.Haskell.Format.Types + +data Settings = + Settings Config + (Maybe [Extension]) + +defaultFormatter :: IO Formatter +defaultFormatter = formatter <$> autoSettings + +autoSettings :: IO Settings +autoSettings = do + config <- getConfig + return $ Settings config $ Just defaultExtensions + +-- | Read config from a config file, or return 'defaultConfig'. +getConfig :: IO Config +getConfig = do + cur <- Path.getCurrentDir + homeDir <- Path.getHomeDir + mfile <- + Path.findFileUp + cur + ((== ".hindent.yaml") . toFilePath . filename) + (Just homeDir) + case mfile of + Nothing -> return defaultConfig + Just file -> do + result <- Y.decodeFileEither (toFilePath file) + case result of + Left e -> error (show e) + Right config -> return config + +formatter :: Settings -> Formatter +formatter = mkFormatter . hindent + +hindent :: Settings -> HaskellSource -> Either String HaskellSource +hindent (Settings config extensions) (HaskellSource filepath source) = + HaskellSource filepath . unpackBuilder <$> + reformat config extensions Nothing sourceText + where + sourceText = Encoding.encodeUtf8 . Text.pack $ source + unpackBuilder = + Text.unpack . Encoding.decodeUtf8 . L.toStrict . toLazyByteString diff --git a/src/Language/Haskell/Format/HLint.hs b/src/Language/Haskell/Format/HLint.hs --- a/src/Language/Haskell/Format/HLint.hs +++ b/src/Language/Haskell/Format/HLint.hs @@ -1,33 +1,33 @@ -module Language.Haskell.Format.HLint - ( autoSettings - , suggester - ) where - -import Language.Haskell.Format.Internal -import Language.Haskell.Format.Types - -import Language.Haskell.HLint3 (Classify, Hint, - ParseError (..), ParseFlags, - applyHints, parseModuleEx) -import qualified Language.Haskell.HLint3 as HLint3 -import System.IO.Unsafe (unsafePerformIO) - -suggester :: (ParseFlags, [Classify], Hint) -> Formatter -suggester = mkSuggester . hlint - -hlint :: - (ParseFlags, [Classify], Hint) - -> HaskellSource - -> Either String [Suggestion] -hlint (flags, classify, hint) (HaskellSource filepath source) = - case unsafePerformIO (parseModuleEx flags filepath (Just source)) of - Right m -> Right . map ideaToSuggestion . ideas $ m - Left parseError -> Left . parseErrorMessage $ parseError - where - ideas m = applyHints classify hint [m] - -autoSettings :: IO (ParseFlags, [Classify], Hint) -autoSettings = HLint3.autoSettings - -ideaToSuggestion :: HLint3.Idea -> Suggestion -ideaToSuggestion = Suggestion . show +module Language.Haskell.Format.HLint + ( autoSettings + , suggester + ) where + +import Language.Haskell.Format.Internal +import Language.Haskell.Format.Types + +import Language.Haskell.HLint3 (Classify, Hint, + ParseError (..), ParseFlags, + applyHints, parseModuleEx) +import qualified Language.Haskell.HLint3 as HLint3 +import System.IO.Unsafe (unsafePerformIO) + +suggester :: (ParseFlags, [Classify], Hint) -> Formatter +suggester = mkSuggester . hlint + +hlint :: + (ParseFlags, [Classify], Hint) + -> HaskellSource + -> Either String [Suggestion] +hlint (flags, classify, hint) (HaskellSource filepath source) = + case unsafePerformIO (parseModuleEx flags filepath (Just source)) of + Right m -> Right . map ideaToSuggestion . ideas $ m + Left parseError -> Left . parseErrorMessage $ parseError + where + ideas m = applyHints classify hint [m] + +autoSettings :: IO (ParseFlags, [Classify], Hint) +autoSettings = HLint3.argsSettings [] + +ideaToSuggestion :: HLint3.Idea -> Suggestion +ideaToSuggestion = Suggestion . show diff --git a/src/Language/Haskell/Format/Internal.hs b/src/Language/Haskell/Format/Internal.hs --- a/src/Language/Haskell/Format/Internal.hs +++ b/src/Language/Haskell/Format/Internal.hs @@ -1,12 +1,12 @@ -module Language.Haskell.Format.Internal - ( mkFormatter - , mkSuggester - ) where - -import Language.Haskell.Format.Types - -mkFormatter :: (HaskellSource -> Either String HaskellSource) -> Formatter -mkFormatter f = Formatter (fmap (\source -> Reformatted source []) . f) - -mkSuggester :: (HaskellSource -> Either String [Suggestion]) -> Formatter -mkSuggester f = Formatter $ \source -> Reformatted source <$> f source +module Language.Haskell.Format.Internal + ( mkFormatter + , mkSuggester + ) where + +import Language.Haskell.Format.Types + +mkFormatter :: (HaskellSource -> Either String HaskellSource) -> Formatter +mkFormatter f = Formatter (fmap (\source -> Reformatted source []) . f) + +mkSuggester :: (HaskellSource -> Either String [Suggestion]) -> Formatter +mkSuggester f = Formatter $ \source -> Reformatted source <$> f source diff --git a/src/Language/Haskell/Format/Stylish.hs b/src/Language/Haskell/Format/Stylish.hs --- a/src/Language/Haskell/Format/Stylish.hs +++ b/src/Language/Haskell/Format/Stylish.hs @@ -1,32 +1,32 @@ -module Language.Haskell.Format.Stylish - ( autoSettings - , formatter - ) where - -import Language.Haskell.Stylish as Stylish - -import Language.Haskell.Format.Internal -import Language.Haskell.Format.Types - -newtype Settings = - Settings Stylish.Config - -autoSettings :: IO Settings -autoSettings = do - path <- Stylish.configFilePath verbose Nothing - config <- Stylish.loadConfig verbose path - return (Settings config) - where - verbose = Stylish.makeVerbose False - -formatter :: Settings -> Formatter -formatter = mkFormatter . stylish - -stylish :: Settings -> HaskellSource -> Either String HaskellSource -stylish (Settings config) (HaskellSource filepath source) = - HaskellSource filepath . unlines <$> - Stylish.runSteps extensions (Just filepath) steps sourceLines - where - sourceLines = lines source - extensions = Stylish.configLanguageExtensions config - steps = Stylish.configSteps config +module Language.Haskell.Format.Stylish + ( autoSettings + , formatter + ) where + +import Language.Haskell.Stylish as Stylish + +import Language.Haskell.Format.Internal +import Language.Haskell.Format.Types + +newtype Settings = + Settings Stylish.Config + +autoSettings :: IO Settings +autoSettings = do + path <- Stylish.configFilePath verbose Nothing + config <- Stylish.loadConfig verbose path + return (Settings config) + where + verbose = Stylish.makeVerbose False + +formatter :: Settings -> Formatter +formatter = mkFormatter . stylish + +stylish :: Settings -> HaskellSource -> Either String HaskellSource +stylish (Settings config) (HaskellSource filepath source) = + HaskellSource filepath . unlines <$> + Stylish.runSteps extensions (Just filepath) steps sourceLines + where + sourceLines = lines source + extensions = Stylish.configLanguageExtensions config + steps = Stylish.configSteps config diff --git a/src/Language/Haskell/Format/Types.hs b/src/Language/Haskell/Format/Types.hs --- a/src/Language/Haskell/Format/Types.hs +++ b/src/Language/Haskell/Format/Types.hs @@ -1,46 +1,52 @@ -module Language.Haskell.Format.Types - ( HaskellSource(..) - , Reformatted(..) - , Formatter(..) - , Suggestion(..) - ) where - -import Control.Monad -import Data.Monoid ((<>)) - -type ErrorString = String - -data HaskellSource = - HaskellSource FilePath - String - deriving (Eq) - -newtype Suggestion = - Suggestion String - -instance Show Suggestion where - show (Suggestion text) = text - -data Reformatted = Reformatted - { reformattedSource :: HaskellSource - , suggestions :: [Suggestion] - } - -instance Monoid Reformatted where - mempty = Reformatted undefined [] - (Reformatted _ suggestionsA) `mappend` (Reformatted sourceB suggestionsB) = - Reformatted sourceB (suggestionsA <> suggestionsB) - -newtype Formatter = Formatter - { unFormatter :: HaskellSource -> Either ErrorString Reformatted - } - -instance Monoid Formatter where - mempty = Formatter (\source -> Right (Reformatted source [])) - (Formatter f) `mappend` (Formatter g) = Formatter (asReformatter g <=< f) - -asReformatter :: - (HaskellSource -> Either ErrorString Reformatted) - -> Reformatted - -> Either ErrorString Reformatted -asReformatter formatter r = (r <>) <$> formatter (reformattedSource r) +module Language.Haskell.Format.Types + ( HaskellSource(..) + , Reformatted(..) + , Formatter(..) + , Suggestion(..) + ) where + +import Control.Monad +import Data.Semigroup (Semigroup, (<>)) + +type ErrorString = String + +data HaskellSource = + HaskellSource FilePath + String + deriving (Eq) + +newtype Suggestion = + Suggestion String + +instance Show Suggestion where + show (Suggestion text) = text + +data Reformatted = Reformatted + { reformattedSource :: HaskellSource + , suggestions :: [Suggestion] + } + +instance Semigroup Reformatted where + (Reformatted _ suggestionsA) <> (Reformatted sourceB suggestionsB) = + Reformatted sourceB (suggestionsA <> suggestionsB) + +instance Monoid Reformatted where + mempty = Reformatted undefined [] + mappend = (<>) + +newtype Formatter = Formatter + { unFormatter :: HaskellSource -> Either ErrorString Reformatted + } + +instance Semigroup Formatter where + (Formatter f) <> (Formatter g) = Formatter (asReformatter g <=< f) + +instance Monoid Formatter where + mempty = Formatter (\source -> Right (Reformatted source [])) + mappend = (<>) + +asReformatter :: + (HaskellSource -> Either ErrorString Reformatted) + -> Reformatted + -> Either ErrorString Reformatted +asReformatter formatter r = (r <>) <$> formatter (reformattedSource r) diff --git a/src/Language/Haskell/Format/Utilities.hs b/src/Language/Haskell/Format/Utilities.hs --- a/src/Language/Haskell/Format/Utilities.hs +++ b/src/Language/Haskell/Format/Utilities.hs @@ -1,105 +1,105 @@ -module Language.Haskell.Format.Utilities - ( defaultFormatter - , hunitTest - , showDiff - , wasReformatted - ) where - -import System.IO.Unsafe - -import Language.Haskell.Format -import Language.Haskell.Source.Enumerator - -import Conduit -import Control.Monad -import Data.Algorithm.DiffContext -import Data.List -import Data.Maybe -import Test.HUnit -import Text.PrettyPrint - -type ErrorString = String - -data CheckResult - = InvalidCheckResult HaskellSource - ErrorString - | CheckResult HaskellSource - Reformatted - -checkResultPath :: CheckResult -> FilePath -checkResultPath (InvalidCheckResult (HaskellSource filepath _) _) = filepath -checkResultPath (CheckResult (HaskellSource filepath _) _) = filepath - -hunitTest :: FilePath -> Test -hunitTest filepath = TestLabel filepath . unsafePerformIO . testPath $ filepath - -testPath :: FilePath -> IO Test -testPath filepath = do - formatter <- defaultFormatter - TestList <$> - runConduit (check formatter filepath .| mapC makeTestCase .| sinkList) - -makeTestCase :: CheckResult -> Test -makeTestCase result = - TestLabel (checkResultPath result) . TestCase $ assertCheckResult result - -assertCheckResult :: CheckResult -> IO () -assertCheckResult result = - case result of - (InvalidCheckResult _ errorString) -> - assertFailure ("Error: " ++ errorString) - (CheckResult source reformatted) -> - when (wasReformatted source reformatted) $ - assertFailure (showReformatted source reformatted) - where - showReformatted :: HaskellSource -> Reformatted -> String - showReformatted source reformatted = - intercalate "\n" $ - catMaybes - [ showSourceChanges source reformatted - , showSuggestions source reformatted - ] - showSourceChanges source reformatted = - whenMaybe - (sourceChanged source reformatted) - (showDiff source (reformattedSource reformatted)) - showSuggestions _ reformatted = - whenMaybe - (hasSuggestions reformatted) - (concatMap show (suggestions reformatted)) - whenMaybe :: Bool -> a -> Maybe a - whenMaybe cond val = const val <$> guard cond - -showDiff :: HaskellSource -> HaskellSource -> String -showDiff (HaskellSource _ a) (HaskellSource _ b) = render (toDoc diff) - where - toDoc = prettyContextDiff (text "Original") (text "Reformatted") text - diff = getContextDiff linesOfContext (lines a) (lines b) - linesOfContext = 1 - -check :: Formatter -> FilePath -> ConduitT () CheckResult IO () -check formatter filepath = - enumeratePath filepath .| mapMC readSourceFile .| - mapC (checkFormatting formatter) - -readSourceFile :: FilePath -> IO HaskellSource -readSourceFile filepath = HaskellSource filepath <$> readFile filepath - -checkFormatting :: Formatter -> HaskellSource -> CheckResult -checkFormatting (Formatter doFormat) source = - case doFormat source of - Left err -> InvalidCheckResult source err - Right reformatted -> CheckResult source reformatted - -defaultFormatter :: IO Formatter -defaultFormatter = mconcat <$> (autoSettings >>= formatters) - -wasReformatted :: HaskellSource -> Reformatted -> Bool -wasReformatted source reformatted = - hasSuggestions reformatted || sourceChanged source reformatted - -sourceChanged :: HaskellSource -> Reformatted -> Bool -sourceChanged source reformatted = source /= reformattedSource reformatted - -hasSuggestions :: Reformatted -> Bool -hasSuggestions reformatted = not (null (suggestions reformatted)) +module Language.Haskell.Format.Utilities + ( defaultFormatter + , hunitTest + , showDiff + , wasReformatted + ) where + +import System.IO.Unsafe + +import Language.Haskell.Format +import Language.Haskell.Source.Enumerator + +import Conduit +import Control.Monad +import Data.Algorithm.DiffContext +import Data.List +import Data.Maybe +import Test.HUnit +import Text.PrettyPrint + +type ErrorString = String + +data CheckResult + = InvalidCheckResult HaskellSource + ErrorString + | CheckResult HaskellSource + Reformatted + +checkResultPath :: CheckResult -> FilePath +checkResultPath (InvalidCheckResult (HaskellSource filepath _) _) = filepath +checkResultPath (CheckResult (HaskellSource filepath _) _) = filepath + +hunitTest :: FilePath -> Test +hunitTest filepath = TestLabel filepath . unsafePerformIO . testPath $ filepath + +testPath :: FilePath -> IO Test +testPath filepath = do + formatter <- defaultFormatter + TestList <$> + runConduit (check formatter filepath .| mapC makeTestCase .| sinkList) + +makeTestCase :: CheckResult -> Test +makeTestCase result = + TestLabel (checkResultPath result) . TestCase $ assertCheckResult result + +assertCheckResult :: CheckResult -> IO () +assertCheckResult result = + case result of + (InvalidCheckResult _ errorString) -> + assertFailure ("Error: " ++ errorString) + (CheckResult source reformatted) -> + when (wasReformatted source reformatted) $ + assertFailure (showReformatted source reformatted) + where + showReformatted :: HaskellSource -> Reformatted -> String + showReformatted source reformatted = + intercalate "\n" $ + catMaybes + [ showSourceChanges source reformatted + , showSuggestions source reformatted + ] + showSourceChanges source reformatted = + whenMaybe + (sourceChanged source reformatted) + (showDiff source (reformattedSource reformatted)) + showSuggestions _ reformatted = + whenMaybe + (hasSuggestions reformatted) + (concatMap show (suggestions reformatted)) + whenMaybe :: Bool -> a -> Maybe a + whenMaybe cond val = const val <$> guard cond + +showDiff :: HaskellSource -> HaskellSource -> String +showDiff (HaskellSource _ a) (HaskellSource _ b) = render (toDoc diff) + where + toDoc = prettyContextDiff (text "Original") (text "Reformatted") text + diff = getContextDiff linesOfContext (lines a) (lines b) + linesOfContext = 1 + +check :: Formatter -> FilePath -> ConduitT () CheckResult IO () +check formatter filepath = + enumeratePath filepath .| mapMC readSourceFile .| + mapC (checkFormatting formatter) + +readSourceFile :: FilePath -> IO HaskellSource +readSourceFile filepath = HaskellSource filepath <$> readFile filepath + +checkFormatting :: Formatter -> HaskellSource -> CheckResult +checkFormatting (Formatter doFormat) source = + case doFormat source of + Left err -> InvalidCheckResult source err + Right reformatted -> CheckResult source reformatted + +defaultFormatter :: IO Formatter +defaultFormatter = mconcat <$> (autoSettings >>= formatters) + +wasReformatted :: HaskellSource -> Reformatted -> Bool +wasReformatted source reformatted = + hasSuggestions reformatted || sourceChanged source reformatted + +sourceChanged :: HaskellSource -> Reformatted -> Bool +sourceChanged source reformatted = source /= reformattedSource reformatted + +hasSuggestions :: Reformatted -> Bool +hasSuggestions reformatted = not (null (suggestions reformatted)) diff --git a/src/Language/Haskell/Source/Enumerator.hs b/src/Language/Haskell/Source/Enumerator.hs --- a/src/Language/Haskell/Source/Enumerator.hs +++ b/src/Language/Haskell/Source/Enumerator.hs @@ -1,78 +1,89 @@ -module Language.Haskell.Source.Enumerator - ( enumeratePath - ) where - -import Conduit -import Control.Applicative -import Control.Monad -import Data.List -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse -import qualified Distribution.Verbosity as Verbosity -import System.Directory -import System.FilePath - -enumeratePath :: FilePath -> ConduitT () FilePath IO () -enumeratePath path = enumPath path .| mapC normalise - -enumPath :: FilePath -> ConduitT () FilePath IO () -enumPath path = do - isDirectory <- lift $ doesDirectoryExist path - case isDirectory of - True -> enumDirectory path - False - | hasCabalExtension path -> enumPackage path - False - | hasHaskellExtension path -> yield path - False -> return () - -enumPackage :: FilePath -> ConduitT () FilePath IO () -enumPackage cabalFile = readPackage cabalFile >>= expandPaths - where - readPackage = lift . readPackageDescription Verbosity.silent - expandPaths = mapM_ (enumPath . mkFull) . sourcePaths - packageDir = dropFileName cabalFile - mkFull = (packageDir ) - -enumDirectory :: FilePath -> ConduitT () FilePath IO () -enumDirectory path = do - contents <- lift $ getDirectoryContentFullPaths path - cabalFiles <- lift $ filterM isCabalFile contents - if null cabalFiles - then mapM_ enumPath contents - else mapM_ enumPackage cabalFiles - -getDirectoryContentFullPaths :: FilePath -> IO [FilePath] -getDirectoryContentFullPaths path = - mkFull . notHidden . notMeta <$> getDirectoryContents path - where - mkFull = map (path ) - notHidden = filter (not . isPrefixOf ".") - notMeta = (\\ [".", ".."]) - -isCabalFile :: FilePath -> IO Bool -isCabalFile path = return (hasCabalExtension path) <&&> doesFileExist path - -hasCabalExtension :: FilePath -> Bool -hasCabalExtension path = ".cabal" `isSuffixOf` path - -hasHaskellExtension :: FilePath -> Bool -hasHaskellExtension path = ".hs" `isSuffixOf` path || ".lhs" `isSuffixOf` path - -sourcePaths :: GenericPackageDescription -> [FilePath] -sourcePaths pkg = nub $ concatMap ($ pkg) pathExtractors - where - pathExtractors = - [ maybe [] (hsSourceDirs . libBuildInfo . condTreeData) . condLibrary - , concatMap (hsSourceDirs . buildInfo . condTreeData . snd) . - condExecutables - , concatMap (hsSourceDirs . testBuildInfo . condTreeData . snd) . - condTestSuites - , concatMap (hsSourceDirs . benchmarkBuildInfo . condTreeData . snd) . - condBenchmarks - ] - -(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool -(<&&>) = liftA2 (&&) - -infixr 3 <&&> -- same as (&&) +{-# LANGUAGE CPP #-} + +module Language.Haskell.Source.Enumerator + ( enumeratePath + ) where + +import Conduit +import Control.Applicative +import Control.Monad +import Data.List +import Distribution.PackageDescription +import qualified Distribution.Verbosity as Verbosity +import System.Directory +import System.FilePath +#if MIN_VERSION_Cabal(2,2,0) +import Distribution.PackageDescription.Parsec (readGenericPackageDescription) +#elif MIN_VERSION_Cabal(2,0,0) +import Distribution.PackageDescription.Parse (readGenericPackageDescription) +#else +import Distribution.PackageDescription.Parse (readPackageDescription) + +readGenericPackageDescription :: + Verbosity.Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = readPackageDescription +#endif +enumeratePath :: FilePath -> ConduitT () FilePath IO () +enumeratePath path = enumPath path .| mapC normalise + +enumPath :: FilePath -> ConduitT () FilePath IO () +enumPath path = do + isDirectory <- lift $ doesDirectoryExist path + case isDirectory of + True -> enumDirectory path + False + | hasCabalExtension path -> enumPackage path + False + | hasHaskellExtension path -> yield path + False -> return () + +enumPackage :: FilePath -> ConduitT () FilePath IO () +enumPackage cabalFile = readPackage cabalFile >>= expandPaths + where + readPackage = lift . readGenericPackageDescription Verbosity.silent + expandPaths = mapM_ (enumPath . mkFull) . sourcePaths + packageDir = dropFileName cabalFile + mkFull = (packageDir ) + +enumDirectory :: FilePath -> ConduitT () FilePath IO () +enumDirectory path = do + contents <- lift $ getDirectoryContentFullPaths path + cabalFiles <- lift $ filterM isCabalFile contents + if null cabalFiles + then mapM_ enumPath contents + else mapM_ enumPackage cabalFiles + +getDirectoryContentFullPaths :: FilePath -> IO [FilePath] +getDirectoryContentFullPaths path = + mkFull . notHidden . notMeta <$> getDirectoryContents path + where + mkFull = map (path ) + notHidden = filter (not . isPrefixOf ".") + notMeta = (\\ [".", ".."]) + +isCabalFile :: FilePath -> IO Bool +isCabalFile path = return (hasCabalExtension path) <&&> doesFileExist path + +hasCabalExtension :: FilePath -> Bool +hasCabalExtension path = ".cabal" `isSuffixOf` path + +hasHaskellExtension :: FilePath -> Bool +hasHaskellExtension path = ".hs" `isSuffixOf` path || ".lhs" `isSuffixOf` path + +sourcePaths :: GenericPackageDescription -> [FilePath] +sourcePaths pkg = nub $ concatMap ($ pkg) pathExtractors + where + pathExtractors = + [ maybe [] (hsSourceDirs . libBuildInfo . condTreeData) . condLibrary + , concatMap (hsSourceDirs . buildInfo . condTreeData . snd) . + condExecutables + , concatMap (hsSourceDirs . testBuildInfo . condTreeData . snd) . + condTestSuites + , concatMap (hsSourceDirs . benchmarkBuildInfo . condTreeData . snd) . + condBenchmarks + ] + +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) + +infixr 3 <&&> -- same as (&&) diff --git a/src/Path/Find.hs b/src/Path/Find.hs --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -1,40 +1,40 @@ -{-# LANGUAGE DataKinds #-} - --- | Finding files. --- Lifted from Stack. -module Path.Find - ( findFileUp - ) where - -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.List -import Path -import Path.IO - --- | Find the location of a file matching the given predicate. -findFileUp :: - (MonadIO m, MonadThrow m) - => Path Abs Dir -- ^ Start here. - -> (Path Abs File -> Bool) -- ^ Predicate to match the file. - -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. - -> m (Maybe (Path Abs File)) -- ^ Absolute file path. -findFileUp = findPathUp snd - --- | Find the location of a path matching the given predicate. -findPathUp :: - (MonadIO m, MonadThrow m) - => (([Path Abs Dir], [Path Abs File]) -> [Path Abs t]) - -- ^ Choose path type from pair. - -> Path Abs Dir -- ^ Start here. - -> (Path Abs t -> Bool) -- ^ Predicate to match the path. - -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. - -> m (Maybe (Path Abs t)) -- ^ Absolute path. -findPathUp pathType dir p upperBound = do - entries <- listDir dir - case find p (pathType entries) of - Just path -> return (Just path) - Nothing - | Just dir == upperBound -> return Nothing - | parent dir == dir -> return Nothing - | otherwise -> findPathUp pathType (parent dir) p upperBound +{-# LANGUAGE DataKinds #-} + +-- | Finding files. +-- Lifted from Stack. +module Path.Find + ( findFileUp + ) where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.List +import Path +import Path.IO + +-- | Find the location of a file matching the given predicate. +findFileUp :: + (MonadIO m, MonadThrow m) + => Path Abs Dir -- ^ Start here. + -> (Path Abs File -> Bool) -- ^ Predicate to match the file. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs File)) -- ^ Absolute file path. +findFileUp = findPathUp snd + +-- | Find the location of a path matching the given predicate. +findPathUp :: + (MonadIO m, MonadThrow m) + => (([Path Abs Dir], [Path Abs File]) -> [Path Abs t]) + -- ^ Choose path type from pair. + -> Path Abs Dir -- ^ Start here. + -> (Path Abs t -> Bool) -- ^ Predicate to match the path. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs t)) -- ^ Absolute path. +findPathUp pathType dir p upperBound = do + entries <- listDir dir + case find p (pathType entries) of + Just path -> return (Just path) + Nothing + | Just dir == upperBound -> return Nothing + | parent dir == dir -> return Nothing + | otherwise -> findPathUp pathType (parent dir) p upperBound diff --git a/test/pure/Spec.hs b/test/pure/Spec.hs --- a/test/pure/Spec.hs +++ b/test/pure/Spec.hs @@ -1,10 +1,10 @@ -module Main - ( main - ) where - -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -main :: IO () -main = defaultMain [] +module Main + ( main + ) where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +main :: IO () +main = defaultMain [] diff --git a/test/self-formatting/Spec.hs b/test/self-formatting/Spec.hs --- a/test/self-formatting/Spec.hs +++ b/test/self-formatting/Spec.hs @@ -1,17 +1,17 @@ -module Main - ( main - ) where - -import Language.Haskell.Format.Utilities - -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -main :: IO () -main = - defaultMain - [ testGroup - "Check formatting of package sources" - (hUnitTestToTests $ hunitTest "hfmt.cabal") - ] +module Main + ( main + ) where + +import Language.Haskell.Format.Utilities + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +main :: IO () +main = + defaultMain + [ testGroup + "Check formatting of package sources" + (hUnitTestToTests $ hunitTest "hfmt.cabal") + ]