Read extensions from cabal file

4 files changed, 242 insertions, 16 deletions

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