Parse cabal setup-config to get depencencies

This commit is contained in:
Daniel Gröber 2014-05-01 01:54:15 +02:00
parent 19b56738c6
commit 0c859294a3
3 changed files with 81 additions and 31 deletions

View File

@ -7,20 +7,26 @@ module Language.Haskell.GhcMod.CabalApi (
, cabalDependPackages , cabalDependPackages
, cabalSourceDirs , cabalSourceDirs
, cabalAllTargets , cabalAllTargets
, cabalGetConfig
, cabalConfigPath
, cabalConfigDependencies
) where ) where
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Utils
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (throwIO) import Control.Exception (throwIO,catch,SomeException)
import Control.Monad (filterM) import Control.Monad (filterM)
import CoreMonad (liftIO) import CoreMonad (liftIO)
import Data.Maybe (maybeToList, catMaybes) import Data.Maybe (maybeToList, mapMaybe)
import Data.Set (fromList, toList) import Data.Set (fromList, toList)
import Data.List (find,tails,isPrefixOf)
import Distribution.ModuleName (ModuleName,toFilePath) import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency) import Distribution.Package (Dependency(Dependency)
, PackageName(PackageName)) , PackageName(PackageName)
, InstalledPackageId(..))
import qualified Distribution.Package as C import qualified Distribution.Package as C
import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable) import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
import qualified Distribution.PackageDescription as P import qualified Distribution.PackageDescription as P
@ -29,12 +35,14 @@ import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
import Distribution.Simple.Program (ghcProgram) import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.Simple.Program.Types (programName, programFindVersion)
import Distribution.Simple.BuildPaths (defaultDistPref)
import Distribution.Simple.Configure (localBuildInfoFile)
import Distribution.System (buildPlatform) import Distribution.System (buildPlatform)
import Distribution.Text (display) import Distribution.Text (display)
import Distribution.Verbosity (silent) import Distribution.Verbosity (silent)
import Distribution.Version (Version) import Distribution.Version (Version)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath (dropExtension, takeFileName, (</>)) import System.FilePath ((</>))
---------------------------------------------------------------- ----------------------------------------------------------------
@ -45,38 +53,13 @@ getCompilerOptions :: [GHCOption]
-> IO CompilerOptions -> IO CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc = do getCompilerOptions ghcopts cradle pkgDesc = do
gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos 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 where
wdir = cradleCurrentDir cradle wdir = cradleCurrentDir cradle
rdir = cradleRootDir cradle rdir = cradleRootDir cradle
Just cfile = cradleCabalFile cradle
thisPkg = dropExtension $ takeFileName cfile
buildInfos = cabalAllBuildInfo pkgDesc buildInfos = cabalAllBuildInfo pkgDesc
idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos 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 -- Include directories for modules
@ -220,3 +203,44 @@ cabalAllTargets pd = do
getExecutableTarget exe = do getExecutableTarget exe = do
let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
liftIO $ filterM doesFileExist maybeExes 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)

View File

@ -9,6 +9,19 @@ import System.IO (hPutStrLn, stderr)
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] 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' :: String -> [String] -> IO String
readProcess' cmd opts = do readProcess' cmd opts = do
(rv,output,err) <- readProcessWithExitCode cmd opts "" (rv,output,err) <- readProcessWithExitCode cmd opts ""

View File

@ -19,6 +19,11 @@ import Config (cProjectVersionInt) -- ghc version
ghcVersion :: Int ghcVersion :: Int
ghcVersion = read cProjectVersionInt ghcVersion = read cProjectVersionInt
unconfigure :: IO ()
unconfigure = do
removeFile cabalConfigPath `catch` (\(_ :: SomeException) -> return ())
around' a f = a >> f >> a
spec :: Spec spec :: Spec
spec = do spec = do
@ -61,3 +66,11 @@ spec = do
it "extracts build info" $ do it "extracts build info" $ do
info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" 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 = []})))]}]" 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