diff --git a/src/Language/Haskell/Stylish/Block.hs b/src/Language/Haskell/Stylish/Block.hs --- a/src/Language/Haskell/Stylish/Block.hs +++ b/src/Language/Haskell/Stylish/Block.hs @@ -10,6 +10,7 @@ , adjacent , merge , overlapping + , groupAdjacent ) where @@ -76,3 +77,15 @@ any (uncurry overlapping') $ zip blocks (drop 1 blocks) where overlapping' (Block _ e1) (Block s2 _) = e1 >= s2 + + +-------------------------------------------------------------------------------- +-- | Groups adjacent blocks into larger blocks +groupAdjacent :: [(Block a, b)] + -> [(Block a, [b])] +groupAdjacent = foldr go [] + where + -- This code is ugly and not optimal, and no fucks were given. + go (b1, x) gs = case break (adjacent b1 . fst) gs of + (_, []) -> (b1, [x]) : gs + (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs --- a/src/Language/Haskell/Stylish/Config.hs +++ b/src/Language/Haskell/Stylish/Config.hs @@ -11,17 +11,18 @@ -------------------------------------------------------------------------------- import Control.Applicative (pure, (<$>), (<*>)) -import Control.Monad (forM, msum, mzero) +import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import qualified Data.ByteString as B -import Data.List (intercalate) +import Data.List (inits, intercalate) import Data.Map (Map) import qualified Data.Map as M import Data.Yaml (decodeEither) import System.Directory -import System.FilePath (()) +import System.FilePath (joinPath, splitPath, + ()) -------------------------------------------------------------------------------- @@ -70,22 +71,26 @@ -------------------------------------------------------------------------------- configFilePath :: Verbose -> Maybe FilePath -> IO (Maybe FilePath) -configFilePath verbose userSpecified = do - (current, currentE) <- check $ ( configFileName) <$> getCurrentDirectory - (home, homeE) <- check $ ( configFileName) <$> getHomeDirectory - (def, defE) <- check defaultConfigFilePath - return $ msum - [ userSpecified - , if currentE then Just current else Nothing - , if homeE then Just home else Nothing - , if defE then Just def else Nothing - ] +configFilePath _ (Just userSpecified) = return $ Just userSpecified +configFilePath verbose Nothing = do + current <- getCurrentDirectory + home <- getHomeDirectory + def <- defaultConfigFilePath + search $ + [d configFileName | d <- ancestors current] ++ + [home configFileName, def] where - check fp = do - fp' <- fp - ex <- doesFileExist fp' - verbose $ fp' ++ if ex then " exists" else " does not exist" - return (fp', ex) + -- All ancestors of a dir (including that dir) + ancestors :: FilePath -> [FilePath] + ancestors = init . map joinPath . reverse . inits . splitPath + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (f : fs) = do + -- TODO Maybe catch an error here, dir might be unreadable + exists <- doesFileExist f + verbose $ f ++ if exists then " exists" else " does not exist" + if exists then return (Just f) else search fs -------------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Stylish/Parse.hs b/src/Language/Haskell/Stylish/Parse.hs --- a/src/Language/Haskell/Stylish/Parse.hs +++ b/src/Language/Haskell/Stylish/Parse.hs @@ -33,21 +33,13 @@ -------------------------------------------------------------------------------- --- | Read an extension name from a string -parseExtension :: String -> Either String H.Extension -parseExtension str = case reads str of - [(x, "")] -> return x - _ -> throwError $ "Unknown extension: " ++ str - - --------------------------------------------------------------------------------- -- | Abstraction over HSE's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module parseModule extraExts mfp string = do - -- Determine the extensions: those specified in the file and the extra ones - extraExts' <- mapM parseExtension extraExts - let fileExts = fromMaybe [] $ H.readExtensions string - exts = fileExts ++ extraExts' + -- Determine the extensions: those specified in the file and the extra ones + let extraExts' = map H.classifyExtension extraExts + fileExts = fromMaybe [] $ H.readExtensions string + exts = fileExts ++ extraExts' -- Parsing options... fp = fromMaybe "" mfp diff --git a/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs --- a/src/Language/Haskell/Stylish/Step/Imports.hs +++ b/src/Language/Haskell/Stylish/Step/Imports.hs @@ -47,20 +47,6 @@ -------------------------------------------------------------------------------- --- | Groups adjacent imports into larger import blocks -groupAdjacent :: [H.ImportDecl LineBlock] - -> [(LineBlock, [H.ImportDecl LineBlock])] -groupAdjacent = foldr go [] - where - -- This code is ugly and not optimal, and no fucks were given. - go imp is = case break (adjacent b1 . fst) is of - (_, []) -> (b1, [imp]) : is - (xs, ((b2, imps) : ys)) -> (merge b1 b2, imp : imps) : (xs ++ ys) - where - b1 = H.ann imp - - --------------------------------------------------------------------------------- -- | Compare imports for ordering compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering compareImports = comparing (map toLower . importName &&& H.importQualified) @@ -179,7 +165,7 @@ where imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' longest = longestImport imps - groups = groupAdjacent imps + groups = groupAdjacent [(H.ann i, i) | i <- imps] fileAlign = case align of File -> any H.importQualified imps diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs --- a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- -import Data.List (nub, sort) +import qualified Data.Set as S import qualified Language.Haskell.Exts.Annotated as H @@ -41,13 +41,11 @@ -------------------------------------------------------------------------------- -verticalPragmas :: [String] -> Lines -verticalPragmas pragmas' = +verticalPragmas :: Int -> [String] -> Lines +verticalPragmas longest pragmas' = [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" | pragma <- pragmas' ] - where - longest = maximum $ map length pragmas' -------------------------------------------------------------------------------- @@ -57,12 +55,29 @@ -------------------------------------------------------------------------------- -prettyPragmas :: Int -> Style -> [String] -> Lines -prettyPragmas _ Vertical = verticalPragmas -prettyPragmas columns Compact = compactPragmas columns +prettyPragmas :: Int -> Int -> Style -> [String] -> Lines +prettyPragmas _ longest Vertical = verticalPragmas longest +prettyPragmas columns _ Compact = compactPragmas columns -------------------------------------------------------------------------------- +-- | Filter redundant (and duplicate) pragmas out of the groups. As a side +-- effect, we also sort the pragmas in their group... +filterRedundant :: (String -> Bool) + -> [(l, [String])] + -> [(l, [String])] +filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) + where + filterRedundant' (l, xs) (known, zs) + | S.null xs' = (known', zs) + | otherwise = (known', (l, S.toAscList xs') : zs) + where + fxs = filter (not . isRedundant') xs + xs' = S.fromList fxs `S.difference` known + known' = xs' `S.union` known + + +-------------------------------------------------------------------------------- step :: Int -> Style -> Bool -> Step step columns style = makeStep "LanguagePragmas" . step' columns style @@ -73,15 +88,17 @@ | null pragmas' = ls | otherwise = applyChanges changes ls where - filterRedundant - | removeRedundant = filter (not . isRedundant module') - | otherwise = id + isRedundant' + | removeRedundant = isRedundant module' + | otherwise = const False pragmas' = pragmas $ fmap linesFromSrcSpan module' - uniques = filterRedundant $ nub $ sort $ snd =<< pragmas' - loc = firstLocation pragmas' - deletes = map (delete . fst) pragmas' - changes = insert loc (prettyPragmas columns style uniques) : deletes + longest = maximum $ map length $ snd =<< pragmas' + groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] + changes = + [ change b (const $ prettyPragmas columns longest style pg) + | (b, pg) <- filterRedundant isRedundant' groups + ] -------------------------------------------------------------------------------- diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.5.4.0 +Version: 0.5.5.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -22,6 +22,7 @@ , testCase "case 02" case02 , testCase "case 03" case03 , testCase "case 04" case04 + , testCase "case 05" case05 ] @@ -90,4 +91,25 @@ [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ "TemplateHaskell," , " TypeOperators, ViewPatterns #-}" + ] + + +-------------------------------------------------------------------------------- +case05 :: Assertion +case05 = expected @=? testStep (step 80 Vertical False) input + where + input = unlines + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] + + expected = unlines + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" ]