From 48f1ac6da51d0e8b53d38f2c57083176edaf5d5e Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 28 Oct 2019 11:33:03 +0000 Subject: Read extensions from cabal file --- lib/Language/Haskell/Stylish/Config.hs | 109 ++++++++++++++++--- stylish-haskell.cabal | 5 + tests/Language/Haskell/Stylish/Config/Tests.hs | 142 +++++++++++++++++++++++++ tests/TestSuite.hs | 2 + 4 files changed, 242 insertions(+), 16 deletions(-) create mode 100644 tests/Language/Haskell/Stylish/Config/Tests.hs diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 6513ff8..b7ada3b 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -16,14 +16,24 @@ 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.Either (isRight) import qualified Data.FileEmbed as FileEmbed -import Data.List (inits, - intercalate) +import Data.List (concatMap, + inits, + intercalate, + nub) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, + maybeToList) import Data.Yaml (decodeEither', prettyPrintParseException) +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription.Parsec as Cabal +import qualified Distribution.Simple.Utils as Cabal +import qualified Distribution.Types.CondTree as Cabal +import qualified Distribution.Verbosity as Cabal +import qualified Language.Haskell.Extension as Language import System.Directory import System.FilePath (joinPath, splitPath, @@ -79,24 +89,23 @@ configFilePath verbose Nothing = do current <- getCurrentDirectory configPath <- getXdgDirectory XdgConfig "stylish-haskell" home <- getHomeDirectory - mbConfig <- search $ + mbConfig <- search verbose $ [d configFileName | d <- ancestors current] ++ [configPath "config.yaml", home configFileName] return mbConfig - where - -- 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 +-- All ancestors of a dir (including that dir) +ancestors :: FilePath -> [FilePath] +ancestors = init . map joinPath . reverse . inits . splitPath +search :: Verbose -> [FilePath] -> IO (Maybe FilePath) +search _ [] = return Nothing +search verbose (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 verbose fs -------------------------------------------------------------------------------- loadConfig :: Verbose -> Maybe FilePath -> IO Config @@ -107,8 +116,76 @@ loadConfig verbose userSpecified = do case decodeEither' bytes of Left err -> error $ "Language.Haskell.Stylish.Config.loadConfig: " ++ prettyPrintParseException err - Right config -> return config + Right config -> do + mbCabalFile <- cabalFilePath verbose + exsFromCabal <- case mbCabalFile of + Just cabalFile -> map show <$> + readDefaultLanguageExtensions verbose cabalFile + Nothing -> return [] + let exsFromConfig = configLanguageExtensions config + return $ config {configLanguageExtensions = nub (exsFromConfig <> exsFromCabal)} + +-------------------------------------------------------------------------------- +-- | Find the closest .cabal file, possibly going up the directory structure. +-- It's essential that +cabalFilePath :: Verbose -> IO (Maybe FilePath) +cabalFilePath verbose = do + potentialProjectRoots <- ancestors <$> getCurrentDirectory + potentialCabalFile <- filter isRight <$> + traverse Cabal.findPackageDesc potentialProjectRoots + case potentialCabalFile of + [Right cabalFile] -> return (Just cabalFile) + _ -> do + verbose $ ".cabal file not found, directories searched: " <> + show potentialProjectRoots + verbose $ "Stylish Haskell will work basing on LANGUAGE pragmas in source files." + return Nothing +-------------------------------------------------------------------------------- +-- | Extract @default-extensions@ fields from a @.cabal@ file +readDefaultLanguageExtensions :: Verbose -> FilePath -> IO [Language.KnownExtension] +readDefaultLanguageExtensions verbose cabalFile = do + verbose $ "Parsing " <> cabalFile <> "..." + packageDescription <- Cabal.readGenericPackageDescription Cabal.silent cabalFile + let library :: [Cabal.Library] + library = maybeToList $ fst . Cabal.ignoreConditions <$> + Cabal.condLibrary packageDescription + + subLibraries :: [Cabal.Library] + subLibraries = fst . Cabal.ignoreConditions . snd <$> + Cabal.condSubLibraries packageDescription + + executables :: [Cabal.Executable] + executables = fst . Cabal.ignoreConditions . snd <$> + Cabal.condExecutables packageDescription + + testSuites :: [Cabal.TestSuite] + testSuites = fst . Cabal.ignoreConditions . snd <$> + Cabal.condTestSuites packageDescription + + benchmarks :: [Cabal.Benchmark] + benchmarks = fst . Cabal.ignoreConditions . snd <$> + Cabal.condBenchmarks packageDescription + + gatherBuildInfos :: [Cabal.BuildInfo] + gatherBuildInfos = map Cabal.libBuildInfo library <> + map Cabal.libBuildInfo subLibraries <> + map Cabal.buildInfo executables <> + map Cabal.testBuildInfo testSuites <> + map Cabal.benchmarkBuildInfo benchmarks + + defaultExtensions :: [Language.KnownExtension] + defaultExtensions = map fromEnabled . filter isEnabled $ + concatMap Cabal.defaultExtensions gatherBuildInfos + where isEnabled (Language.EnableExtension _) = True + isEnabled _ = False + + fromEnabled (Language.EnableExtension x) = x + fromEnabled x = + error $ "Language.Haskell.Stylish.Config.readLanguageExtensions: " <> + "invalid LANGUAGE pragma: " <> show x + verbose $ "Gathered default-extensions: " <> show defaultExtensions + pure $ nub defaultExtensions -------------------------------------------------------------------------------- parseConfig :: A.Value -> A.Parser Config diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index bb4ad46..9de3eb6 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -52,6 +52,7 @@ Library aeson >= 0.6 && < 1.5, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, + Cabal >= 2.4.0.1, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, @@ -76,6 +77,7 @@ Executable stylish-haskell base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.7, + Cabal >= 2.4.0.1, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, @@ -94,6 +96,7 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block Language.Haskell.Stylish.Config + Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Editor Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests @@ -120,11 +123,13 @@ Test-suite stylish-haskell-tests HUnit >= 1.2 && < 1.7, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, + random >= 1.1, -- Copied from regular dependencies... aeson >= 0.6 && < 1.5, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.7, + Cabal >= 2.4.0.1, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs new file mode 100644 index 0000000..f62b571 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -0,0 +1,142 @@ +module Language.Haskell.Stylish.Config.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception hiding (assert) +import qualified Data.Set as Set +import System.Directory +import System.FilePath (()) +import System.IO.Error +import System.Random +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert) +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Config" + [ testCase "Extensions extracted correctly from .cabal file" + testExtensionsFromDotCabal + , testCase "Extensions extracted correctly from .stylish-haskell.yaml file" + testExtensionsFromDotStylish + , testCase "Extensions extracted correctly from .stylish-haskell.yaml and .cabal files" + testExtensionsFromBoth + ] +-------------------------------------------------------------------------------- + +-- | Create a temporary directory with a randomised name built from the template provided +createTempDirectory :: String -> IO FilePath +createTempDirectory template = do + tmpRootDir <- getTemporaryDirectory + dirId <- randomIO :: IO Word + findTempName tmpRootDir dirId + where + findTempName :: FilePath -> Word -> IO FilePath + findTempName tmpRootDir x = do + let dirpath = tmpRootDir template ++ show x + r <- try $ createDirectory dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName tmpRootDir (x+1) + | otherwise -> ioError e + +-- | Perform an action inside a temporary directory tree and purge the tree afterwords +withTestDirTree :: IO a -> IO a +withTestDirTree action = bracket + ((,) <$> getCurrentDirectory <*> createTempDirectory "stylish_haskell") + (\(current, temp) -> + setCurrentDirectory current *> + removeDirectoryRecursive temp) + (\(_, temp) -> setCurrentDirectory temp *> action) + +-- | Put an example config files (.cabal/.stylish-haskell.yaml/both) +-- into the current directory and extract extensions from it. +createFilesAndGetExtensions :: [(FilePath, String)] -> IO Extensions +createFilesAndGetExtensions files = withTestDirTree $ do + mapM_ (\(k, v) -> writeFile k v) files + -- create an empty directory and change into it + createDirectory "src" + setCurrentDirectory "src" + -- from that directory read the config file and extract extensions + -- to make sure the search for .cabal file works + config <- loadConfig (const (pure ())) Nothing + pure $ configLanguageExtensions config + +-------------------------------------------------------------------------------- +testExtensionsFromDotCabal :: Assertion +testExtensionsFromDotCabal = + assert $ (expected ==) . Set.fromList <$> + createFilesAndGetExtensions [("test.cabal", dotCabal True)] + where + expected = Set.fromList ["ScopedTypeVariables", "DataKinds"] + +-------------------------------------------------------------------------------- +testExtensionsFromDotStylish :: Assertion +testExtensionsFromDotStylish = + assert $ (expected ==) . Set.fromList <$> + createFilesAndGetExtensions [(".stylish-haskell.yaml", dotStylish)] + where + expected = Set.fromList ["TemplateHaskell", "QuasiQuotes"] + +-------------------------------------------------------------------------------- +testExtensionsFromBoth :: Assertion +testExtensionsFromBoth = + assert $ (expected ==) . Set.fromList <$> + createFilesAndGetExtensions [ ("test.cabal", dotCabal True) + , (".stylish-haskell.yaml", dotStylish)] + where + expected = Set.fromList + ["ScopedTypeVariables", "DataKinds", "TemplateHaskell", "QuasiQuotes"] + +-- | Example cabal file borrowed from +-- https://www.haskell.org/cabal/users-guide/developing-packages.html +-- with some default-extensions added +dotCabal :: Bool -> String +dotCabal includeExtensions = unlines $ + [ "name: TestPackage" + , "version: 0.0" + , "synopsis: Package with library and two programs" + , "license: BSD3" + , "author: Angela Author" + , "build-type: Simple" + , "cabal-version: >= 1.2" + , "" + , "library" + , " build-depends: HUnit" + , " exposed-modules: A, B, C" + ] ++ + [if includeExtensions then " default-extensions: ScopedTypeVariables" + else ""] + ++ + [ "" + , "executable program1" + , " main-is: Main.hs" + , " hs-source-dirs: prog1" + , " other-modules: A, B" + ] ++ + [if includeExtensions then " default-extensions: DataKinds" + else ""] + +-- | Example .stylish-haskell.yaml +dotStylish :: String +dotStylish = unlines $ + [ "steps:" + , " - imports:" + , " align: none" + , " list_align: after_alias" + , " long_list_align: inline" + , " separate_lists: true" + , " - language_pragmas:" + , " style: vertical" + , " align: false" + , " remove_redundant: true" + , " - trailing_whitespace: {}" + , "columns: 110" + , "language_extensions:" + , " - TemplateHaskell" + , " - QuasiQuotes" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 27963a0..b5bec90 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -9,6 +9,7 @@ import Test.Framework (default -------------------------------------------------------------------------------- +import qualified Language.Haskell.Stylish.Config.Tests import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests @@ -23,6 +24,7 @@ import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests main :: IO () main = defaultMain [ Language.Haskell.Stylish.Parse.Tests.tests + , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests -- cgit v1.2.3