diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 080c2f98..b3b5af91 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -64,6 +64,15 @@ steps: # to. Different steps take this into account. Default: 80. columns: 80 +# How most things are wrapped. +# +# - regular: Default style, trailing commas +# +# - utrecht: Leading commas +# +# Default: regular. +wrap_style: regular + # 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. diff --git a/src/Language/Haskell/Stylish.hs b/src/Language/Haskell/Stylish.hs index 7a52aa27..90635431 100644 --- a/src/Language/Haskell/Stylish.hs +++ b/src/Language/Haskell/Stylish.hs @@ -10,6 +10,7 @@ module Language.Haskell.Stylish , trailingWhitespace , unicodeSyntax -- ** Data types + , WrapStyle (..) , Imports.Align (..) , LanguagePragmas.Style (..) -- ** Helpers @@ -34,6 +35,7 @@ import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Verbose import Language.Haskell.Stylish.Parse +import Language.Haskell.Stylish.Wrap import Paths_stylish_haskell (version) import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas @@ -44,14 +46,16 @@ import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax -------------------------------------------------------------------------------- -imports :: Int -- ^ columns +imports :: WrapStyle + -> Int -- ^ columns -> Imports.Align -> Step imports = Imports.step -------------------------------------------------------------------------------- -languagePragmas :: Int -- ^ columns +languagePragmas :: WrapStyle + -> Int -- ^ columns -> LanguagePragmas.Style -> Bool -- ^ remove redundant? -> Step diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs index 6c05e0a3..02cf3484 100644 --- a/src/Language/Haskell/Stylish/Config.hs +++ b/src/Language/Haskell/Stylish/Config.hs @@ -35,6 +35,7 @@ import qualified Language.Haskell.Stylish.Step.Tabs as Tabs import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax import Language.Haskell.Stylish.Verbose +import Language.Haskell.Stylish.Wrap -------------------------------------------------------------------------------- @@ -45,6 +46,7 @@ type Extensions = [String] data Config = Config { configSteps :: [Step] , configColumns :: Int + , configWrapStyle :: WrapStyle , configLanguageExtensions :: [String] } @@ -56,7 +58,7 @@ instance FromJSON Config where -------------------------------------------------------------------------------- emptyConfig :: Config -emptyConfig = Config [] 80 [] +emptyConfig = Config [] 80 Regular [] -------------------------------------------------------------------------------- @@ -116,12 +118,19 @@ parseConfig (A.Object o) = do -- First load the config without the actual steps config <- Config <$> pure [] - <*> (o A..:? "columns" A..!= 80) + <*> (o A..:? "columns" A..!= 80) + <*> (o A..:? "wrap_style" >>= parseEnum wrapStyles Regular) <*> (o A..:? "language_extensions" A..!= []) -- Then fill in the steps based on the partial config we already have steps <- (o A..: "steps" >>= fmap concat . mapM (parseSteps config)) return config {configSteps = steps} + where + wrapStyles = + [ ("regular", Regular) + , ("utrecht", Utrecht) + ] + parseConfig _ = mzero @@ -159,7 +168,8 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step parseImports config o = Imports.step - <$> pure (configColumns config) + <$> pure (configWrapStyle config) + <*> pure (configColumns config) <*> (o A..:? "align" >>= parseEnum aligns Imports.Global) where aligns = @@ -173,7 +183,8 @@ parseImports config o = Imports.step -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step - <$> pure (configColumns config) + <$> pure (configWrapStyle config) + <*> pure (configColumns config) <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) <*> o A..:? "remove_redundant" A..!= True where diff --git a/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs index 3f2e4f65..f221a705 100644 --- a/src/Language/Haskell/Stylish/Step/Imports.hs +++ b/src/Language/Haskell/Stylish/Step/Imports.hs @@ -111,16 +111,17 @@ prettyImportSpec x = H.prettyPrint x -------------------------------------------------------------------------------- -prettyImport :: Int -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] -prettyImport columns padQualified padName longest imp = - regularWrap columns (length base + 2) $ +prettyImport :: WrapStyle -> Int -> Bool -> Bool -> Int -> H.ImportDecl l + -> [String] +prettyImport wrapStyle columns padQualified padName longest imp = + wrapWith wrapStyle columns $ case importSpecs of - Nothing -> [Open base] -- Import everything - Just [] -> [Open base, Space, Close "()"] -- Instance only imports + Nothing -> [String base] -- Import everything + Just [] -> [String base, Space, String "()"] -- Instance only Just is -> - [Open base, Space, String "("] ++ + [String (base ++ " (")] ++ intersperse Comma (map (String . prettyImportSpec) is) ++ - [Close ")"] + [String ")"] where base = unwords $ concat [ ["import"] @@ -145,10 +146,10 @@ prettyImport columns padQualified padName longest imp = -------------------------------------------------------------------------------- -prettyImportGroup :: Int -> Align -> Bool -> Int -> [H.ImportDecl LineBlock] - -> Lines -prettyImportGroup columns align fileAlign longest imps = - concatMap (prettyImport columns padQual padName longest') $ +prettyImportGroup :: WrapStyle -> Int -> Align -> Bool -> Int + -> [H.ImportDecl LineBlock] -> Lines +prettyImportGroup wrapStyle columns align fileAlign longest imps = + concatMap (prettyImport wrapStyle columns padQual padName longest') $ sortBy compareImports imps where longest' = case align of @@ -165,15 +166,15 @@ prettyImportGroup columns align fileAlign longest imps = -------------------------------------------------------------------------------- -step :: Int -> Align -> Step -step columns = makeStep "Imports" . step' columns +step :: WrapStyle -> Int -> Align -> Step +step wrapStyle columns = makeStep "Imports" . step' wrapStyle columns -------------------------------------------------------------------------------- -step' :: Int -> Align -> Lines -> Module -> Lines -step' columns align ls (module', _) = flip applyChanges ls +step' :: WrapStyle -> Int -> Align -> Lines -> Module -> Lines +step' wrapStyle columns align ls (module', _) = flip applyChanges ls [ change block $ const $ - prettyImportGroup columns align fileAlign longest importGroup + prettyImportGroup wrapStyle columns align fileAlign longest importGroup | (block, importGroup) <- groups ] where diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 326fe6fa..45fad44d 100644 --- a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -52,27 +52,28 @@ verticalPragmas pragmas' = -------------------------------------------------------------------------------- -compactPragmas :: Int -> [String] -> Lines -compactPragmas columns pragmas' = regularWrap columns 13 $ - [Open "{-# LANGUAGE"] ++ +compactPragmas :: WrapStyle -> Int -> [String] -> Lines +compactPragmas wrapStyle columns pragmas' = wrapWith wrapStyle columns $ + [String "{-# LANGUAGE", Space] ++ intersperse Comma (map String pragmas') ++ - [Space, Close "#-}"] + [Space, String "#-}"] -------------------------------------------------------------------------------- -prettyPragmas :: Int -> Style -> [String] -> Lines -prettyPragmas _ Vertical = verticalPragmas -prettyPragmas columns Compact = compactPragmas columns +prettyPragmas :: WrapStyle -> Int -> Style -> [String] -> Lines +prettyPragmas _ _ Vertical = verticalPragmas +prettyPragmas wrapStyle columns Compact = compactPragmas wrapStyle columns -------------------------------------------------------------------------------- -step :: Int -> Style -> Bool -> Step -step columns style = makeStep "LanguagePragmas" . step' columns style +step :: WrapStyle -> Int -> Style -> Bool -> Step +step wrapStyle columns style = makeStep "LanguagePragmas" . + step' wrapStyle columns style -------------------------------------------------------------------------------- -step' :: Int -> Style -> Bool -> Lines -> Module -> Lines -step' columns style removeRedundant ls (module', _) +step' :: WrapStyle -> Int -> Style -> Bool -> Lines -> Module -> Lines +step' wrapStyle columns style removeRedundant ls (module', _) | null pragmas' = ls | otherwise = applyChanges changes ls where @@ -84,7 +85,8 @@ step' columns style removeRedundant ls (module', _) uniques = filterRedundant $ nub $ sort $ snd =<< pragmas' loc = firstLocation pragmas' deletes = map (delete . fst) pragmas' - changes = insert loc (prettyPragmas columns style uniques) : deletes + changes = + insert loc (prettyPragmas wrapStyle columns style uniques) : deletes -------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Stylish/Wrap.hs b/src/Language/Haskell/Stylish/Wrap.hs index bd66d78b..92eed7a8 100644 --- a/src/Language/Haskell/Stylish/Wrap.hs +++ b/src/Language/Haskell/Stylish/Wrap.hs @@ -1,7 +1,10 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Wrap - ( Wrap (..) + ( WrapStyle (..) + , Wrap (..) + , wrapWith , regularWrap + , utrechtWrap ) where @@ -10,38 +13,46 @@ import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util +-------------------------------------------------------------------------------- +data WrapStyle + = Regular + | Utrecht + deriving (Show) + + -------------------------------------------------------------------------------- data Wrap - = Open String - | Close String - | String String + = String String | Space | Comma deriving (Show) +-------------------------------------------------------------------------------- +wrapWith :: WrapStyle -- ^ Wrapping style to use + -> Int -- ^ Maximum line width + -> [Wrap] -- ^ Stuff to wrap + -> Lines -- ^ Resulting lines +wrapWith Regular = regularWrap +wrapWith Utrecht = utrechtWrap + + -------------------------------------------------------------------------------- regularWrap :: Int -- ^ Maximum line width - -> Int -- ^ Indentation -> [Wrap] -- ^ Stuff to wrap -> Lines -- ^ Resulting lines -regularWrap maxWidth indentation wraps = - let (leading, strs) = regularJoin wraps - in wrap " " maxWidth indentation leading strs +regularWrap maxWidth wraps = + let (leading : strs) = regularJoin wraps + in wrap " " maxWidth (length leading) leading strs -------------------------------------------------------------------------------- -regularJoin :: [Wrap] -> (String, [String]) -regularJoin wraps = case wraps of - (Open x : xs) -> (x, go xs) - _ -> error $ "Language.Haskell.Stylish.Wrap.regularJoin: " ++ - "wrap spec should start with Open but got: " ++ show wraps +regularJoin :: [Wrap] -> [String] +regularJoin wraps = go wraps where go (String x : String y : xs) = go (String (x ++ y) : xs) go (String x : Comma : xs) = (x ++ ",") : go xs - go (String x : Space : xs) = x : go xs - go (String x : Close y : []) = [x ++ y] - go (Close x : []) = [x] + go (String x : xs) = x : go xs go (Space : xs) = go xs go [] = [] go ws = error $ @@ -49,6 +60,41 @@ regularJoin wraps = case wraps of show ws ++ " is invalid, in: " ++ show wraps +-------------------------------------------------------------------------------- +utrechtWrap :: Int -- ^ Maximum line width + -> [Wrap] -- ^ Stuff to wrap + -> Lines -- ^ Resulting lines +utrechtWrap maxWidth wraps = + -- If we can put everything on one line, we use regular wrapping + case regularWrap maxWidth wraps of + [line] -> [line] + xs + | length utrechts < 3 -> xs -- Should not happen! + | otherwise -> + let (leading : strs) = utrechts + in wrap "" maxWidth (length leading - 1) + (leading ++ " ") (init strs) ++ + [replicate (length leading - 1) ' ' ++ last strs] + where + utrechts = utrechtJoin wraps + + +-------------------------------------------------------------------------------- +utrechtJoin :: [Wrap] -> [String] +utrechtJoin wraps = case wraps of + (String x : xs) -> x : go xs -- Never join first string in utrecht style + _ -> go wraps -- Should this ever happen? + where + go (Space : xs) = go xs + go (String x : String y : xs) = go (String (x ++ y) : xs) + go (Comma : String x : xs) = (", " ++ x ) : go xs + go (String x : xs) = x : go xs + go [] = [] + go ws = error $ + "Language.Haskell.Stylish.Wrap.regularJoin: go: " ++ + show ws ++ " is invalid, in: " ++ show wraps + + -------------------------------------------------------------------------------- wrap :: String -- ^ Optional space string -> Int -- ^ Maximum line width diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index c62fe0f6..aec557b2 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -5,14 +5,15 @@ module Language.Haskell.Stylish.Step.Imports.Tests -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util +import Language.Haskell.Stylish.Wrap -------------------------------------------------------------------------------- @@ -47,7 +48,7 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 80 Global) input +case01 = expected @=? testStep (step Regular 80 Global) input where expected = unlines [ "module Herp where" @@ -66,7 +67,7 @@ case01 = expected @=? testStep (step 80 Global) input -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step 80 Group) input +case02 = expected @=? testStep (step Regular 80 Group) input where expected = unlines [ "module Herp where" @@ -85,7 +86,7 @@ case02 = expected @=? testStep (step 80 Group) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step 80 None) input +case03 = expected @=? testStep (step Regular 80 None) input where expected = unlines [ "module Herp where" @@ -104,7 +105,7 @@ case03 = expected @=? testStep (step 80 None) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step 80 Global) input' +case04 = expected @=? testStep (step Regular 80 Global) input' where input' = "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ @@ -119,7 +120,7 @@ case04 = expected @=? testStep (step 80 Global) input' -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep (step 80 Group) input' +case05 = input' @=? testStep (step Regular 80 Group) input' where input' = "import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)\n" @@ -127,7 +128,7 @@ case05 = input' @=? testStep (step 80 Group) input' -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep (step 80 File) input' +case06 = input' @=? testStep (step Regular 80 File) input' where input' = unlines [ "import Bar.Qux" @@ -137,7 +138,7 @@ case06 = input' @=? testStep (step 80 File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step 80 File) input' +case07 = expected @=? testStep (step Regular 80 File) input' where input' = unlines [ "import Bar.Qux" diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 716d56a7..bb906f31 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -5,14 +5,16 @@ module Language.Haskell.Stylish.Step.LanguagePragmas.Tests -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, + (@=?)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.LanguagePragmas import Language.Haskell.Stylish.Tests.Util +import Language.Haskell.Stylish.Wrap -------------------------------------------------------------------------------- @@ -27,7 +29,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 80 Vertical False) input +case01 = expected @=? testStep (step Regular 80 Vertical False) input where input = unlines [ "{-# LANGUAGE ViewPatterns #-}" @@ -46,7 +48,7 @@ case01 = expected @=? testStep (step 80 Vertical False) input -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step 80 Vertical True) input +case02 = expected @=? testStep (step Regular 80 Vertical True) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -62,7 +64,7 @@ case02 = expected @=? testStep (step 80 Vertical True) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step 80 Vertical True) input +case03 = expected @=? testStep (step Regular 80 Vertical True) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -78,7 +80,7 @@ case03 = expected @=? testStep (step 80 Vertical True) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step 80 Compact False) input +case04 = expected @=? testStep (step Regular 80 Compact False) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"