From 250e7091edd93ce5a476706ddd968ef3ec1ef336 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 2 Oct 2020 13:08:39 +0200 Subject: Use ghc-lib-parser rather than haskell-src-exts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This patch swaps out the parsing library from `haskell-src-exts` to `ghc-lib-parser`, which gives us better compatibility with GHC. Because almost every module heavily used the Haskell AST provided by `haskell-src-exts`, this was a huge effort and it would not have been possible without Felix Mulder doing an initial port, GSoC student Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and Paweł Szulc who helped me finish up things in the home stretch. I've generally tried to keep styling 100% compatible with what was there before, but some issues may have unintentionally slipped in so please report those. This introduces one new import styling contributed by Felix: when wrapping import lists over multiple lines, you can repeat the module name, e.g.: import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither) import Control.Monad.Except as X (runExceptT, withExceptT) This is activated by using `import_align: repeat`. Secondly, a new Step was added, `module_header`, which formats the export list of a module, including the trailing `where` clause. Details for this new step can be found in the `data/stylish-haskell.yaml`. Co-Authored-By: Beatrice Vergani Co-Authored-By: Paweł Szulc Co-Authored-By: Łukasz Gołębiewski Co-Authored-By: Felix Mulder --- data/stylish-haskell.yaml | 59 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) (limited to 'data/stylish-haskell.yaml') diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index d7de260..80892dc 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -15,6 +15,19 @@ steps: # # true. # add_language_pragma: true + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # Format record definitions. This is disabled by default. # # You can control the layout of record fields. The only rules that can't be configured @@ -42,6 +55,31 @@ steps: # # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # via: "indent 2" + # + # # Wheter or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single @@ -101,6 +139,11 @@ steps: # > import qualified Data.List as List # > (concat, foldl, foldr, head, init, last, length) # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # # Default: after_alias list_align: after_alias @@ -203,6 +246,22 @@ steps: # Default: false space_surround: false + # Enabling this argument will use the new GHC lib parse to format imports. + # + # This currently assumes a few things, it will assume that you want post + # qualified imports. It is also not as feature complete as the old + # imports formatting. + # + # It does not remove redundant lines or merge lines. As such, the full + # feature scope is still pending. + # + # It _is_ however, a fine alternative if you are using features that are + # not parseable by haskell src extensions and you're comfortable with the + # presets. + # + # Default: false + ghc_lib_parser: false + # Language pragmas - language_pragmas: # We can generate different styles of language pragma lists. -- cgit v1.2.3 From 84ff4e57eb24b5b5ab95ad7b64419846922e00f7 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 5 Oct 2020 21:28:37 +0300 Subject: Make sorting deriving list optional (#316) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Make sorting deriving list optional Not everyone wants their typeclasses sorted. * Remove redundant code Co-authored-by: Łukasz Gołębiewski --- data/stylish-haskell.yaml | 7 +++++-- lib/Language/Haskell/Stylish/Config.hs | 1 + lib/Language/Haskell/Stylish/Step/Data.hs | 4 +++- tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 23 ++++++++++++++++++----- 4 files changed, 27 insertions(+), 8 deletions(-) (limited to 'data/stylish-haskell.yaml') diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 80892dc..0a2e21a 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -58,10 +58,13 @@ steps: # # # How many spaces to insert before "via" clause counted from indentation of deriving clause # # Possible values: - # # - "same_line" -- "{" and first field goes on the same line as the data constructor. - # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. # via: "indent 2" # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # # # Wheter or not to break enums onto several lines # # # # Default: false diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 333736f..68638a6 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -221,6 +221,7 @@ parseRecords c o = Data.step <*> (o A..:? "break_single_constructors" A..!= True) <*> (o A..: "via" >>= parseIndent) <*> (o A..:? "curried_context" A..!= False) + <*> (o A..:? "sort_deriving" A..!= True) <*> pure configMaxColumns) where configMaxColumns = diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index bf39c7c..523389b 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -71,6 +71,8 @@ data Config = Config -- ^ Indentation between @via@ clause and start of deriving column start , cCurriedContext :: !Bool -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + , cSortDeriving :: !Bool + -- ^ If true, will sort type classes in a @deriving@ list. , cMaxColumns :: !MaxColumns } deriving (Show) @@ -266,7 +268,7 @@ putDeriving Config{..} (L pos clause) = do = clause & deriv_clause_tys & unLocated - & sortBy compareOutputable + & (if cSortDeriving then sortBy compareOutputable else id) & fmap hsib_body headTy = diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 4357af6..9ed9d0d 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -65,6 +65,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 52" case52 , testCase "case 53" case53 , testCase "case 54" case54 + , testCase "case 55" case55 ] case00 :: Assertion @@ -1200,17 +1201,29 @@ case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumn , " deriving newtype (Applicative, Functor, Monad)" ] +case55 :: Assertion +case55 = expected @=? testStep (step sameSameNoSortStyle) input + where + input = unlines + [ "data Foo = Foo deriving (Z, Y, X, Bar, Abcd)" + ] + + expected = input + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False NoMaxColumns +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns + +sameSameNoSortStyle :: Config +sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns -- cgit v1.2.3 From 10ce71bb79cf9f6ab47ac9dfef503529c41bef00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 12:55:32 +0200 Subject: ModuleHeader: Add separate_lists option See #320 --- data/stylish-haskell.yaml | 3 +++ lib/Language/Haskell/Stylish/Config.hs | 7 +++++-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 18 ++++++++++-------- .../Haskell/Stylish/Step/ModuleHeader/Tests.hs | 12 ++++++++++++ 4 files changed, 30 insertions(+), 10 deletions(-) (limited to 'data/stylish-haskell.yaml') diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 0a2e21a..e0a739c 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -27,6 +27,9 @@ steps: # # Should export lists be sorted? Sorting is only performed within the # # export section, as delineated by Haddock comments. # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true # Format record definitions. This is disabled by default. # diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 68638a6..36688a5 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -195,8 +195,11 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config - <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig) - <*> o A..:? "sort" A..!= (ModuleHeader.sort ModuleHeader.defaultConfig) + <$> o A..:? "indent" A..!= ModuleHeader.indent def + <*> o A..:? "sort" A..!= ModuleHeader.sort def + <*> o A..:? "separate_lists" A..!= ModuleHeader.separateLists def + where + def = ModuleHeader.defaultConfig -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 90f3478..0c33298 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -40,16 +40,16 @@ import Language.Haskell.Stylish.Step data Config = Config - -- TODO(jaspervdj): Use the same sorting as in `Imports`? - -- TODO: make sorting optional? - { indent :: Int - , sort :: Bool + { indent :: Int + , sort :: Bool + , separateLists :: Bool } defaultConfig :: Config defaultConfig = Config - { indent = 4 - , sort = True + { indent = 4 + , sort = True + , separateLists = True } step :: Config -> Step @@ -218,13 +218,15 @@ printExportList conf (L srcLoc exports) = do printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] printExportsGroupTail [] = pure () + -- NOTE(jaspervdj): This code is almost the same as the import printing + -- in 'Imports' and should be merged. printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of IEVar _ name -> putOutputable name IEThingAbs _ name -> putOutputable name IEThingAll _ name -> do putOutputable name - space + when (separateLists conf) space putText "(..)" IEModuleContents _ (L _ m) -> do putText "module" @@ -232,7 +234,7 @@ printExportList conf (L srcLoc exports) = do putText (showOutputable m) IEThingWith _ name _wildcard imps _ -> do putOutputable name - space + when (separateLists conf) space putText "(" sep (comma >> space) $ fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index b6d6b89..002be7c 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -34,6 +34,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Indents with 2 spaces" ex14 , testCase "Group doc with 2 spaces" ex15 , testCase "Does not sort" ex16 + , testCase "Repects separate_lists" ex17 ] -------------------------------------------------------------------------------- @@ -299,3 +300,14 @@ ex16 = assertSnippet (step defaultConfig {sort = False}) input input , " , no" , " ) where" ] + +ex17 :: Assertion +ex17 = assertSnippet (step defaultConfig {separateLists = False}) + [ "module Foo" + , " ( Bar (..)" + , " ) where" + ] + [ "module Foo" + , " ( Bar(..)" + , " ) where" + ] -- cgit v1.2.3 From eab76694dfbbd10fce74b8ac59bf523a96cf37fa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 8 Oct 2020 13:49:50 +0200 Subject: SimpleAlign: add multi_way_if flag in config --- data/stylish-haskell.yaml | 1 + lib/Language/Haskell/Stylish/Config.hs | 3 ++- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 30 +++++++++++----------- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 12 +++++++++ 4 files changed, 30 insertions(+), 16 deletions(-) (limited to 'data/stylish-haskell.yaml') diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index e0a739c..9709184 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -94,6 +94,7 @@ steps: cases: true top_level_patterns: true records: true + multi_way_if: true # Import cleanup - imports: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 36688a5..682d7d7 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -208,7 +208,8 @@ parseSimpleAlign c o = SimpleAlign.step <*> (SimpleAlign.Config <$> withDef SimpleAlign.cCases "cases" <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records") + <*> withDef SimpleAlign.cRecords "records" + <*> withDef SimpleAlign.cMultiWayIf "multi_way_if") where withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index e03f665..523a6fb 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , defaultConfig @@ -28,6 +29,7 @@ data Config = Config { cCases :: !Bool , cTopLevelPatterns :: !Bool , cRecords :: !Bool + , cMultiWayIf :: !Bool } deriving (Show) @@ -37,6 +39,7 @@ defaultConfig = Config { cCases = True , cTopLevelPatterns = True , cRecords = True + , cMultiWayIf = True } @@ -136,21 +139,18 @@ matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable - :: Config - -> Hs.LHsExpr Hs.GhcPs + :: Hs.LHsExpr Hs.GhcPs -> [Alignable S.RealSrcSpan] -multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = - fromMaybe [] $ traverse (grhsToAlignable conf) grhss -multiWayIfToAlignable _conf _ = [] +multiWayIfToAlignable (S.L _ (Hs.HsMultiIf _ grhss)) = + fromMaybe [] $ traverse grhsToAlignable grhss +multiWayIfToAlignable _ = [] -------------------------------------------------------------------------------- grhsToAlignable - :: Config - -> S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) -grhsToAlignable conf (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do - guard $ cCases conf +grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do let guardsLocs = map S.getLoc guards bodyLoc = S.getLoc body left = foldl1' S.combineSrcSpans guardsLocs @@ -163,13 +163,13 @@ grhsToAlignable conf (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable _conf (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x -grhsToAlignable _conf (S.L _ _) = Nothing +grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls module' -> +step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> let changes :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) -> (a -> [Alignable S.RealSrcSpan]) @@ -179,7 +179,7 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> configured :: [Change String] configured = concat $ - [changes records recordToAlignable | cRecords config] ++ + [changes records recordToAlignable | cRecords ] ++ [changes everything (matchGroupToAlignable config)] ++ - [changes everything (multiWayIfToAlignable config)] in + [changes everything multiWayIfToAlignable | cMultiWayIf] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 5b502d1..827022c 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -32,6 +32,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 11" case11 , testCase "case 12" case12 , testCase "case 13" case13 + , testCase "case 13b" case13b ] @@ -213,3 +214,14 @@ case13 = assertSnippet (step Nothing defaultConfig) , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] + +case13b :: Assertion +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] -- cgit v1.2.3 From 9f1e714f3d5ebee208a25fe8adaf89c34de5b04b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 8 Oct 2020 14:34:34 +0200 Subject: Add new option for aligning groups of adjacent items Co-authored-by: 1computer1 --- .gitignore | 1 + data/stylish-haskell.yaml | 15 ++-- lib/Language/Haskell/Stylish/Config.hs | 32 +++++--- lib/Language/Haskell/Stylish/GHC.hs | 40 ++++----- lib/Language/Haskell/Stylish/Module.hs | 30 +++---- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 95 +++++++++++++--------- tests/Language/Haskell/Stylish/Config/Tests.hs | 29 ++++++- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 82 ++++++++++++++++++- 8 files changed, 230 insertions(+), 94 deletions(-) (limited to 'data/stylish-haskell.yaml') diff --git a/.gitignore b/.gitignore index 738ffe6..37d51d4 100644 --- a/.gitignore +++ b/.gitignore @@ -17,5 +17,6 @@ cabal-dev cabal.config cabal.sandbox.config cabal.sandbox.config +cabal.project.local dist /dist-newstyle/ diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 9709184..e756b16 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -89,12 +89,17 @@ steps: # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single - # line. All default to true. + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. - simple_align: - cases: true - top_level_patterns: true - records: true - multi_way_if: true + cases: always + top_level_patterns: always + records: always + multi_way_if: always # Import cleanup - imports: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 682d7d7..dde9d0d 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,10 +10,12 @@ module Language.Haskell.Stylish.Config , defaultConfigBytes , configFilePath , loadConfig + , parseConfig ) where -------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A @@ -43,8 +45,8 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports -import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash import qualified Language.Haskell.Stylish.Step.Tabs as Tabs @@ -74,7 +76,7 @@ data ExitCodeBehavior deriving (Eq) instance Show ExitCodeBehavior where - show NormalExitBehavior = "normal" + show NormalExitBehavior = "normal" show ErrorOnFormatExitBehavior = "error_on_format" -------------------------------------------------------------------------------- @@ -206,12 +208,22 @@ parseSimpleAlign :: Config -> A.Object -> A.Parser Step parseSimpleAlign c o = SimpleAlign.step <$> pure (configColumns c) <*> (SimpleAlign.Config - <$> withDef SimpleAlign.cCases "cases" - <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records" - <*> withDef SimpleAlign.cMultiWayIf "multi_way_if") + <$> parseAlign "cases" SimpleAlign.cCases + <*> parseAlign "top_level_patterns" SimpleAlign.cTopLevelPatterns + <*> parseAlign "records" SimpleAlign.cRecords + <*> parseAlign "multi_way_if" SimpleAlign.cMultiWayIf) where - withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) + parseAlign key f = + (o A..:? key >>= parseEnum aligns (f SimpleAlign.defaultConfig)) <|> + (boolToAlign <$> o A..: key) + aligns = + [ ("always", SimpleAlign.Always) + , ("adjacent", SimpleAlign.Adjacent) + , ("never", SimpleAlign.Never) + ] + boolToAlign True = SimpleAlign.Always + boolToAlign False = SimpleAlign.Never + -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step @@ -295,8 +307,8 @@ parseImports config o = fmap (Imports.step columns) $ Imports.Options parseListPadding = \case A.String "module_name" -> pure Imports.LPModuleName - A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) - v -> A.typeMismatch "'module_name' or >=1 number" v + A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) + v -> A.typeMismatch "'module_name' or >=1 number" v -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index ee2d59f..c99d4bf 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -6,6 +6,7 @@ module Language.Haskell.Stylish.GHC , dropBeforeLocated , dropBeforeAndAfter -- * Unsafe getters + , unsafeGetRealSrcSpan , getEndLineUnsafe , getStartLineUnsafe -- * Standard settings @@ -18,32 +19,33 @@ module Language.Haskell.Stylish.GHC ) where -------------------------------------------------------------------------------- -import Data.Function (on) +import Data.Function (on) -------------------------------------------------------------------------------- -import DynFlags (Settings(..), defaultDynFlags) -import qualified DynFlags as GHC -import FileSettings (FileSettings(..)) -import GHC.Fingerprint (fingerprint0) +import DynFlags (Settings (..), defaultDynFlags) +import qualified DynFlags as GHC +import FileSettings (FileSettings (..)) +import GHC.Fingerprint (fingerprint0) import GHC.Platform -import GHC.Version (cProjectVersion) -import GhcNameVersion (GhcNameVersion(..)) -import PlatformConstants (PlatformConstants(..)) -import SrcLoc (GenLocated(..), SrcSpan(..)) -import SrcLoc (Located, RealLocated) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -import ToolSettings (ToolSettings(..)) -import qualified Outputable as GHC +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion (..)) +import qualified Outputable as GHC +import PlatformConstants (PlatformConstants (..)) +import SrcLoc (GenLocated (..), Located, RealLocated, + RealSrcSpan, SrcSpan (..), srcSpanEndLine, + srcSpanStartLine) +import ToolSettings (ToolSettings (..)) + +unsafeGetRealSrcSpan :: Located a -> RealSrcSpan +unsafeGetRealSrcSpan = \case + (L (RealSrcSpan s) _) -> s + _ -> error "could not get source code location" getStartLineUnsafe :: Located a -> Int -getStartLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanStartLine s - _ -> error "could not get start line of block" +getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan getEndLineUnsafe :: Located a -> Int -getEndLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanEndLine s - _ -> error "could not get end line of block" +getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropAfterLocated loc xs = case loc of diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 2cc8f47..3dbebe0 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -24,6 +24,7 @@ module Language.Haskell.Stylish.Module , moduleComments , moduleLanguagePragmas , queryModule + , groupByLine -- * Imports , canMergeImport @@ -192,22 +193,21 @@ moduleImports m -- | Get groups of imports from module moduleImportGroups :: Module -> [NonEmpty (Located Import)] -moduleImportGroups = go [] Nothing . moduleImports +moduleImportGroups = groupByLine unsafeGetRealSrcSpan . moduleImports + +-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. +groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] +groupByLine f = go [] Nothing where - -- Run through all imports (assume they are sorted already in order of - -- appearance in the file) and group the ones that are on consecutive - -- lines. - go :: [Located Import] -> Maybe Int -> [Located Import] - -> [NonEmpty (Located Import)] - go acc _ [] = ne acc - go acc mbCurrentLine (imp : impRest) = - let - lStart = getStartLineUnsafe imp - lEnd = getEndLineUnsafe imp in - case mbCurrentLine of - Just lPrevEnd | lPrevEnd + 1 < lStart - -> ne acc ++ go [imp] (Just lEnd) impRest - _ -> go (acc ++ [imp]) (Just lEnd) impRest + go acc _ [] = ne acc + go acc mbCurrentLine (x:xs) = + let + lStart = GHC.srcSpanStartLine (f x) + lEnd = GHC.srcSpanEndLine (f x) in + case mbCurrentLine of + Just lPrevEnd | lPrevEnd + 1 < lStart + -> ne acc ++ go [x] (Just lEnd) xs + _ -> go (acc ++ [x]) (Just lEnd) xs ne [] = [] ne (x : xs) = [x :| xs] diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 523a6fb..f8aea50 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -3,14 +3,16 @@ {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) + , Align (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- -import Control.Monad (guard) -import Data.List (foldl', foldl1') +import Data.Either (partitionEithers) +import Data.Foldable (toList) +import Data.List (foldl', foldl1', sortOn) import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -26,22 +28,34 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Config = Config - { cCases :: !Bool - , cTopLevelPatterns :: !Bool - , cRecords :: !Bool - , cMultiWayIf :: !Bool + { cCases :: Align + , cTopLevelPatterns :: Align + , cRecords :: Align + , cMultiWayIf :: Align } deriving (Show) +data Align + = Always + | Adjacent + | Never + deriving (Eq, Show) --------------------------------------------------------------------------------- defaultConfig :: Config defaultConfig = Config - { cCases = True - , cTopLevelPatterns = True - , cRecords = True - , cMultiWayIf = True + { cCases = Always + , cTopLevelPatterns = Always + , cRecords = Always + , cMultiWayIf = Always } +groupAlign :: Align -> [Alignable S.RealSrcSpan] -> [[Alignable S.RealSrcSpan]] +groupAlign a xs = case a of + Never -> [] + Adjacent -> byLine . sortOn (S.srcSpanStartLine . aLeft) $ xs + Always -> [xs] + where + byLine = map toList . groupByLine aLeft + -------------------------------------------------------------------------------- type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] @@ -65,8 +79,8 @@ records modu = do -------------------------------------------------------------------------------- -recordToAlignable :: Record -> [Alignable S.RealSrcSpan] -recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable +recordToAlignable :: Config -> Record -> [[Alignable S.RealSrcSpan]] +recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- @@ -89,36 +103,36 @@ fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) - -> [Alignable S.RealSrcSpan] + -> [[Alignable S.RealSrcSpan]] matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x -matchGroupToAlignable conf (Hs.MG _ alts _) = - fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts) +matchGroupToAlignable conf (Hs.MG _ alts _) = cases' ++ patterns' + where + (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (S.unLoc alts) + cases' = groupAlign (cCases conf) cases + patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- matchToAlignable - :: Config - -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) - -> Maybe (Alignable S.RealSrcSpan) -matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Either (Alignable S.RealSrcSpan) (Alignable S.RealSrcSpan)) +matchToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do let patsLocs = map S.getLoc pats pat = last patsLocs guards = getGuards m guardsLocs = map S.getLoc guards left = foldl' S.combineSrcSpans pat guardsLocs - guard $ cCases conf body <- rhsBody grhss matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left rightPos <- toRealSrcSpan $ S.getLoc body - Just $ Alignable + Just . Left $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = rightPos , aRightLead = length "-> " } -matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do - guard $ cTopLevelPatterns conf +matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do body <- unguardedRhsBody grhss let patsLocs = map S.getLoc pats nameLoc = S.getLoc name @@ -127,23 +141,26 @@ matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _ matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left bodyPos <- toRealSrcSpan bodyLoc - Just $ Alignable + Just . Right $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing +matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable - :: Hs.LHsExpr Hs.GhcPs - -> [Alignable S.RealSrcSpan] -multiWayIfToAlignable (S.L _ (Hs.HsMultiIf _ grhss)) = - fromMaybe [] $ traverse grhsToAlignable grhss -multiWayIfToAlignable _ = [] + :: Config + -> Hs.LHsExpr Hs.GhcPs + -> [[Alignable S.RealSrcSpan]] +multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = + groupAlign (cMultiWayIf conf) as + where + as = fromMaybe [] $ traverse grhsToAlignable grhss +multiWayIfToAlignable _conf _ = [] -------------------------------------------------------------------------------- @@ -163,8 +180,8 @@ grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x -grhsToAlignable (S.L _ _) = Nothing +grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing -------------------------------------------------------------------------------- @@ -172,14 +189,14 @@ step :: Maybe Int -> Config -> Step step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> let changes :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) - -> (a -> [Alignable S.RealSrcSpan]) + -> (a -> [[Alignable S.RealSrcSpan]]) -> [Change String] - changes search toAlign = concat $ - map (align maxColumns) . map toAlign $ search (parsedModule module') + changes search toAlign = + (concatMap . concatMap) (align maxColumns) . map toAlign $ search (parsedModule module') configured :: [Change String] configured = concat $ - [changes records recordToAlignable | cRecords ] ++ + [changes records (recordToAlignable config)] ++ [changes everything (matchGroupToAlignable config)] ++ - [changes everything multiWayIfToAlignable | cMultiWayIf] in + [changes everything (multiWayIfToAlignable config)] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs index 73062ab..3af6249 100644 --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -4,11 +4,14 @@ module Language.Haskell.Stylish.Config.Tests -------------------------------------------------------------------------------- -import qualified Data.Set as Set +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Set as Set +import qualified Data.YAML.Aeson as Yaml import System.Directory -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert, (@?=)) -------------------------------------------------------------------------------- @@ -31,6 +34,8 @@ tests = testGroup "Language.Haskell.Stylish.Config" testSpecifiedColumns , testCase "Correctly read .stylish-haskell.yaml file with no max column number" testNoColumns + , testCase "Backwards-compatible align options" + testBoolSimpleAlign ] @@ -105,6 +110,22 @@ testNoColumns = expected = Nothing +-------------------------------------------------------------------------------- +testBoolSimpleAlign :: Assertion +testBoolSimpleAlign = do + Right val <- pure $ Yaml.decode1 $ BL8.pack config + Aeson.Success conf <- pure $ Aeson.parse parseConfig val + length (configSteps conf) @?= 1 + where + config = unlines + [ "steps:" + , " - simple_align:" + , " cases: true" + , " top_level_patterns: always" + , " records: false" + ] + + -- | Example cabal file borrowed from -- https://www.haskell.org/cabal/users-guide/developing-packages.html -- with some default-extensions added diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 827022c..e30f0ba 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -33,6 +33,10 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 12" case12 , testCase "case 13" case13 , testCase "case 13b" case13b + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 ] @@ -194,7 +198,7 @@ case11 = assertSnippet (step Nothing defaultConfig) -------------------------------------------------------------------------------- case12 :: Assertion -case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input +case12 = assertSnippet (step Nothing defaultConfig { cCases = Never }) input input where input = [ "case x of" @@ -216,7 +220,7 @@ case13 = assertSnippet (step Nothing defaultConfig) ] case13b :: Assertion -case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) [ "cond n = if" , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" @@ -225,3 +229,77 @@ case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = False}) , " | n < 10, x <- 1 -> x" , " | otherwise -> 2" ] + + +-------------------------------------------------------------------------------- +case14 :: Assertion +case14 = assertSnippet (step (Just 80) defaultConfig { cCases = Adjacent }) + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + + +-------------------------------------------------------------------------------- +case15 :: Assertion +case15 = assertSnippet (step (Just 80) defaultConfig { cTopLevelPatterns = Adjacent }) + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + + +-------------------------------------------------------------------------------- +case16 :: Assertion +case16 = assertSnippet (step (Just 80) defaultConfig { cRecords = Adjacent }) + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case17 :: Assertion +case17 = assertSnippet (step Nothing defaultConfig { cMultiWayIf = Adjacent }) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] -- cgit v1.2.3