diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 05fee51..07bff93 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/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) - 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) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 09a87a5..cd04a3e 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/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 "" diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 6e4998c..6586ab7 100644 --- a/test/CabalApiSpec.hs +++ b/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