ghc-mod/Language/Haskell/GhcMod/CabalApi.hs

293 lines
11 KiB
Haskell
Raw Normal View History

2014-01-08 13:16:10 +00:00
{-# LANGUAGE OverloadedStrings, CPP #-}
2013-03-03 06:47:03 +00:00
2013-05-17 01:00:01 +00:00
module Language.Haskell.GhcMod.CabalApi (
2013-09-19 07:21:48 +00:00
getCompilerOptions
, parseCabalFile
, cabalAllBuildInfo
2013-09-16 00:56:08 +00:00
, 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 ((<$>))
2014-05-08 01:49:40 +00:00
import Control.Exception (SomeException(..))
import qualified Control.Exception as E
import Control.Monad (filterM,mplus)
import CoreMonad (liftIO)
import Data.Maybe (maybeToList)
import Data.Set (fromList, toList)
import Data.List (find,tails,isPrefixOf,nub,stripPrefix)
import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency)
, PackageName(PackageName)
, InstalledPackageId(..)
, PackageIdentifier)
import qualified Distribution.Package as C
2014-03-27 06:17:58 +00:00
import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
import qualified Distribution.PackageDescription as P
import Distribution.PackageDescription.Configuration (finalizePackageDescription)
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
2013-03-04 04:55:03 +00:00
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion)
import Distribution.Simple.BuildPaths (defaultDistPref)
import Distribution.Simple.Configure (localBuildInfoFile)
2014-05-08 09:50:51 +00:00
import Distribution.Simple.LocalBuildInfo (ComponentLocalBuildInfo(..), ComponentName)
import Distribution.System (buildPlatform)
2013-03-01 06:25:43 +00:00
import Distribution.Text (display)
import Distribution.Verbosity (silent)
2013-09-20 08:21:10 +00:00
import Distribution.Version (Version)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
----------------------------------------------------------------
2013-09-20 01:30:51 +00:00
-- | Getting necessary 'CompilerOptions' from three information sources.
getCompilerOptions :: [GHCOption]
-> Cradle
-> PackageDescription
-> IO CompilerOptions
2013-09-19 07:21:48 +00:00
getCompilerOptions ghcopts cradle pkgDesc = do
gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
depPkgs <- cabalConfigDependencies (C.packageId pkgDesc) <$> cabalGetConfig cradle
return $ CompilerOptions gopts idirs depPkgs
2013-03-03 06:47:03 +00:00
where
2013-05-13 03:57:58 +00:00
wdir = cradleCurrentDir cradle
rdir = cradleRootDir cradle
2013-09-19 07:21:48 +00:00
buildInfos = cabalAllBuildInfo pkgDesc
idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
2013-09-16 02:15:34 +00:00
----------------------------------------------------------------
-- Include directories for modules
2013-09-16 01:55:26 +00:00
cabalBuildDirs :: [FilePath]
cabalBuildDirs = ["dist/build", "dist/build/autogen"]
2013-09-16 01:55:26 +00:00
2013-09-16 02:00:39 +00:00
includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
2013-09-16 01:55:26 +00:00
includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
where
2013-09-20 02:22:11 +00:00
extdirs = map expand $ dirs ++ cabalBuildDirs
expand "." = cdir
expand subdir = cdir </> subdir
2013-03-03 06:47:03 +00:00
----------------------------------------------------------------
2013-09-16 00:56:08 +00:00
-- | Parsing a cabal file and returns 'PackageDescription'.
-- 'IOException' is thrown if parsing fails.
parseCabalFile :: FilePath -> IO PackageDescription
parseCabalFile file = do
cid <- getGHCId
epgd <- readPackageDescription silent file
case toPkgDesc cid epgd of
2014-05-08 01:49:40 +00:00
Left deps -> E.throwIO $ userError $ show deps ++ " are not installed"
Right (pd,_) -> if nullPkg pd
2014-05-08 01:49:40 +00:00
then E.throwIO $ userError $ file ++ " is broken"
else return pd
where
toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []
nullPkg pd = name == ""
where
PackageName name = C.pkgName (P.package pd)
----------------------------------------------------------------
getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
getGHCOptions ghcopts cradle rdir binfo = do
cabalCpp <- cabalCppOptions rdir
2014-03-27 06:17:58 +00:00
let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
2013-03-05 01:21:55 +00:00
where
pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
2014-03-27 06:17:58 +00:00
lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo
libDirs = map ("-L" ++) $ P.extraLibDirs binfo
exts = map (("-X" ++) . display) $ P.usedExtensions binfo
libs = map ("-l" ++) $ P.extraLibs binfo
2013-09-16 02:15:34 +00:00
cabalCppOptions :: FilePath -> IO [String]
cabalCppOptions dir = do
exist <- doesFileExist cabalMacro
2014-03-27 07:31:49 +00:00
return $ if exist then
["-include", cabalMacro]
else
2014-03-27 07:31:49 +00:00
[]
where
cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"
2013-03-05 01:21:55 +00:00
----------------------------------------------------------------
-- | Extracting all 'BuildInfo' for libraries, executables, and tests.
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
2014-04-25 18:48:20 +00:00
cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
where
2014-03-27 06:17:58 +00:00
libBI = map P.libBuildInfo $ maybeToList $ P.library pd
execBI = map P.buildInfo $ P.executables pd
testBI = map P.testBuildInfo $ P.testSuites pd
#if __GLASGOW_HASKELL__ >= 704
2014-04-25 18:48:20 +00:00
benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd
#else
benchBI = []
#endif
----------------------------------------------------------------
2013-09-16 00:56:08 +00:00
-- | Extracting package names of dependency.
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
2014-03-27 07:31:49 +00:00
cabalDependPackages bis = uniqueAndSort pkgs
where
2014-03-27 06:17:58 +00:00
pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis
getDependencyPackageName (Dependency (PackageName nm) _) = nm
2013-03-05 01:21:55 +00:00
----------------------------------------------------------------
2013-09-16 00:56:08 +00:00
-- | Extracting include directories for modules.
cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
2014-03-27 06:17:58 +00:00
cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis
2013-09-16 00:56:08 +00:00
----------------------------------------------------------------
2013-03-01 06:25:43 +00:00
uniqueAndSort :: [String] -> [String]
uniqueAndSort = toList . fromList
2013-03-04 04:55:03 +00:00
----------------------------------------------------------------
getGHCId :: IO CompilerId
getGHCId = CompilerId GHC <$> getGHC
getGHC :: IO Version
getGHC = do
mv <- programFindVersion ghcProgram silent (programName ghcProgram)
case mv of
2014-05-08 01:49:40 +00:00
Nothing -> E.throwIO $ userError "ghc not found"
2014-03-27 07:31:49 +00:00
Just v -> return v
----------------------------------------------------------------
-- | Extracting all 'Module' 'FilePath's for libraries, executables,
-- tests and benchmarks.
cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])
cabalAllTargets pd = do
2014-03-27 06:17:58 +00:00
exeTargets <- mapM getExecutableTarget $ P.executables pd
testTargets <- mapM getTestTarget $ P.testSuites pd
2013-09-21 15:26:55 +00:00
return (libTargets,concat exeTargets,concat testTargets,benchTargets)
where
2014-03-27 06:17:58 +00:00
lib = case P.library pd of
Nothing -> []
2014-03-27 06:17:58 +00:00
Just l -> P.libModules l
2014-03-27 07:31:49 +00:00
libTargets = map toModuleString lib
2014-01-08 13:16:10 +00:00
#if __GLASGOW_HASKELL__ >= 704
2014-03-27 06:17:58 +00:00
benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
2014-01-08 13:16:10 +00:00
#else
benchTargets = []
#endif
toModuleString :: ModuleName -> String
toModuleString mn = fromFilePath $ toFilePath mn
fromFilePath :: FilePath -> String
fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
2013-09-21 15:26:55 +00:00
getTestTarget :: TestSuite -> IO [String]
getTestTarget ts =
2014-03-27 06:17:58 +00:00
case P.testInterface ts of
2013-09-21 15:26:55 +00:00
(TestSuiteExeV10 _ filePath) -> do
2014-03-27 06:17:58 +00:00
let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]
2013-09-21 15:26:55 +00:00
liftIO $ filterM doesFileExist maybeTests
(TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]
(TestSuiteUnsupported _) -> return []
getExecutableTarget :: Executable -> IO [String]
getExecutableTarget exe = do
2014-03-27 06:17:58 +00:00
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 =
2014-05-08 01:49:40 +00:00
readFile path `E.catch` (\(SomeException _) -> configure >> readFile path)
where
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 :: PackageIdentifier -> CabalConfig -> [Package]
cabalConfigDependencies thisPkg config = cfgDepends
where
pids :: [InstalledPackageId]
pids = let
mps = map fst <$> (components18 thisPkg `mplus` components16 thisPkg)
in case mps of
Just ps -> ps
Nothing -> errorExtract
cfgDepends = filter (("inplace" /=) . pkgId)
$ fromInstalledPackageId <$> pids
errorExtract = error $
"cabalConfigDependencies: Error extracting dependencies from setup-config"
-- Cabal 1.18
components18 :: PackageIdentifier
-> Maybe [(InstalledPackageId,PackageIdentifier)]
components18 _ =
concatMap (componentPackageDeps . lbi)
<$> extractCabalSetupConfig config "componentsConfigs"
lbi :: (ComponentName, ComponentLocalBuildInfo, [ComponentName])
-> ComponentLocalBuildInfo
lbi (_,i,_) = i
-- Cabal 1.16 and below
components16 :: PackageIdentifier
-> Maybe [(InstalledPackageId,PackageIdentifier)]
components16 thisPkg' = filter (not . internal . snd) . nub <$> do
cbi <- concat <$> sequence [ extract "executableConfigs"
, extract "testSuiteConfigs"
, extract "benchmarkConfigs" ]
:: Maybe [(String, ComponentLocalBuildInfo)]
return $ maybe [] componentPackageDeps libraryConfig
++ concatMap (componentPackageDeps . snd) cbi
where
2014-05-08 09:50:51 +00:00
-- True if this dependency is an internal one (depends on the library
-- defined in the same package).
internal pkgid = pkgid == thisPkg'
libraryConfig :: Maybe ComponentLocalBuildInfo
libraryConfig = do
field <- find ("libraryConfig" `isPrefixOf`) (tails config)
clbi <- stripPrefix " = " field
if "Nothing" `isPrefixOf` clbi
then Nothing
else read <$> stripPrefix "Just " clbi
extract :: Read r => String -> Maybe r
extract field = extractCabalSetupConfig config field
-- | 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 Tuples in
-- the field!
extractCabalSetupConfig :: (Read r) => CabalConfig -> String -> Maybe r
extractCabalSetupConfig config field = do
read <$> extractParens <$> find (field `isPrefixOf`) (tails config)