Parse cabal setup-config
to get depencencies
This commit is contained in:
parent
19b56738c6
commit
0c859294a3
@ -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)
|
||||
return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
|
||||
Just depPkgs <- cabalConfigDependencies <$> cabalGetConfig cradle
|
||||
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)
|
||||
|
@ -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 ""
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user