Parse cabal setup-config to get depencencies

Language/Haskell/GhcMod/CabalApi.hs

@@ -7,20 +7,26 @@ module Language.Haskell.GhcMod.CabalApi (
   , cabalDependPackages
   , cabalSourceDirs
   , cabalAllTargets
+  , cabalGetConfig
+  , cabalConfigPath
+  , cabalConfigDependencies
   ) where
 
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.Utils
 
 import Control.Applicative ((<$>))
-import Control.Exception (throwIO)
+import Control.Exception (throwIO,catch,SomeException)
 import Control.Monad (filterM)
 import CoreMonad (liftIO)
-import Data.Maybe (maybeToList, catMaybes)
+import Data.Maybe (maybeToList, mapMaybe)
 import Data.Set (fromList, toList)
+import Data.List (find,tails,isPrefixOf)
 import Distribution.ModuleName (ModuleName,toFilePath)
 import Distribution.Package (Dependency(Dependency)
-                           , PackageName(PackageName))
+                           , PackageName(PackageName)
+                           , InstalledPackageId(..))
 import qualified Distribution.Package as C
 import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
 import qualified Distribution.PackageDescription as P
@@ -29,12 +35,14 @@ import Distribution.PackageDescription.Parse (readPackageDescription)
 import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
 import Distribution.Simple.Program (ghcProgram)
 import Distribution.Simple.Program.Types (programName, programFindVersion)
+import Distribution.Simple.BuildPaths (defaultDistPref)
+import Distribution.Simple.Configure (localBuildInfoFile)
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 import Distribution.Verbosity (silent)
 import Distribution.Version (Version)
 import System.Directory (doesFileExist)
-import System.FilePath (dropExtension, takeFileName, (</>))
+import System.FilePath ((</>))
 
 ----------------------------------------------------------------
 
@@ -45,38 +53,13 @@ getCompilerOptions :: [GHCOption]
                    -> IO CompilerOptions
 getCompilerOptions ghcopts cradle pkgDesc = do
     gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
-    dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)
+    Just depPkgs <- cabalConfigDependencies <$> cabalGetConfig cradle
-    return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
+    return $ CompilerOptions gopts idirs depPkgs
   where
     wdir       = cradleCurrentDir cradle
     rdir       = cradleRootDir    cradle
-    Just cfile = cradleCabalFile  cradle
-    thisPkg    = dropExtension $ takeFileName cfile
     buildInfos = cabalAllBuildInfo pkgDesc
     idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
-    depPkgs ps = attachPackageIds ps
-                   $ removeThem (problematicPackages ++ [thisPkg])
-                   $ cabalDependPackages buildInfos
-
-----------------------------------------------------------------
--- Dependent packages
-
-removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]
-removeThem badpkgs = filter (`notElem` badpkgs)
-
-problematicPackages :: [PackageBaseName]
-problematicPackages = [
-    "base-compat" -- providing "Prelude"
-  ]
-
-attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]
-attachPackageIds pkgs = catMaybes . fmap (`lookup3` pkgs)
-
-lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)
-lookup3 _ [] = Nothing
-lookup3 k (t@(a,_,_):ls)
-    | k == a = Just t
-    | otherwise = lookup3 k ls
 
 ----------------------------------------------------------------
 -- Include directories for modules
@@ -220,3 +203,44 @@ cabalAllTargets pd = do
     getExecutableTarget exe = do
       let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
       liftIO $ filterM doesFileExist maybeExes
+
+----------------------------------------------------------------
+
+type CabalConfig = String
+
+-- | Get file containing 'LocalBuildInfo' data. If it doesn't exist run @cabal
+-- configure@ i.e. configure with default options like @cabal build@ would do.
+cabalGetConfig :: Cradle -> IO CabalConfig
+cabalGetConfig cradle =
+    readFile path `catch'` (\_ -> configure >> readFile path)
+ where
+   catch' = catch :: IO a -> (SomeException -> IO a) -> IO a
+   prjDir = cradleRootDir cradle
+   path = prjDir </> cabalConfigPath
+   configure =
+     withDirectory_ prjDir $ readProcess' "cabal" ["configure"]
+
+
+-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
+cabalConfigPath :: FilePath
+cabalConfigPath = localBuildInfoFile defaultDistPref
+
+cabalConfigDependencies :: CabalConfig -> Maybe [Package]
+cabalConfigDependencies config =
+    cfgDepends >>= return . mapMaybe (fromInstalledPackageId . snd)
+ where
+    cfgDepends :: Maybe [(PackageName, InstalledPackageId)]
+    cfgDepends =  extractCabalSetupConfig "configDependencies" config
+
+
+-- | Extract part of cabal's @setup-config@, this is done with a mix of manual
+-- string processing and use of 'read'. This way we can extract a field from
+-- 'LocalBuildInfo' without having to parse the whole thing which would mean
+-- depending on the exact version of Cabal used to configure the project as it
+-- is rather likley that some part of 'LocalBuildInfo' changed.
+--
+-- Right now 'extractCabalSetupConfig' can only deal with Lists and Tupels in
+-- the field!
+extractCabalSetupConfig :: (Read r) => String -> CabalConfig -> Maybe r
+extractCabalSetupConfig  field config = do
+    read <$> extractParens <$> find (field `isPrefixOf`) (tails config)

Language/Haskell/GhcMod/Utils.hs

@@ -9,6 +9,19 @@ import System.IO (hPutStrLn, stderr)
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
 dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
+
+extractParens :: String -> String
+extractParens str = extractParens' str 0
+ where
+   extractParens' :: String -> Int -> String
+   extractParens' [] _ = []
+   extractParens' (s:ss) level
+       | s `elem` "([{" = s : extractParens' ss (level+1)
+       | level == 0 = extractParens' ss 0
+       | s `elem` "}])" && level == 1 = s:[]
+       | s `elem` "}])" = s : extractParens' ss (level-1)
+       | otherwise = s : extractParens' ss level
+
 readProcess' :: String -> [String] -> IO String
 readProcess' cmd opts = do
   (rv,output,err) <- readProcessWithExitCode cmd opts ""

test/CabalApiSpec.hs

@@ -19,6 +19,11 @@ import Config (cProjectVersionInt) -- ghc version
 ghcVersion :: Int
 ghcVersion = read cProjectVersionInt
 
+unconfigure :: IO ()
+unconfigure = do
+  removeFile cabalConfigPath `catch` (\(_ :: SomeException) ->  return ())
+
+around' a f = a >> f >> a
 
 spec :: Spec
 spec = do
@@ -61,3 +66,11 @@ spec = do
         it "extracts build info" $ do
             info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
             show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"
+
+    describe "cabalGetConfig" $ do
+        it "can reconfigure a cabal package" $ do
+            withDirectory_ "test/data/check-test-subdir"
+              $ around' unconfigure $ do
+                cradle <- findCradle
+                cfg <- cabalGetConfig cradle
+                cfg `shouldSatisfy` not . null