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

224 lines
8.3 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
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>))
2013-03-04 04:55:03 +00:00
import Control.Exception (throwIO)
import Control.Monad (filterM)
import CoreMonad (liftIO)
import Data.Maybe (maybeToList)
import Data.Set (fromList, toList)
import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency)
, PackageName(PackageName)
, PackageIdentifier(pkgName))
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.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)
2014-03-27 06:17:58 +00:00
import System.FilePath (dropExtension, takeFileName, (</>))
----------------------------------------------------------------
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
dbPkgs <- getPackageDbPackages rdir
return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
2013-03-03 06:47:03 +00:00
where
2013-05-13 03:57:58 +00:00
wdir = cradleCurrentDir cradle
rdir = cradleRootDir cradle
2013-03-04 01:39:39 +00:00
Just cfile = cradleCabalFile cradle
pkgs = cradlePackages cradle
2013-09-19 07:21:48 +00:00
buildInfos = cabalAllBuildInfo pkgDesc
idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
depPkgs ps = attachPackageIds pkgs
$ removeThem problematicPackages
$ removeMe cfile
$ filter (`elem` ps) -- remove packages not available in any
-- package dbs
$ cabalDependPackages buildInfos
2013-03-03 06:47:03 +00:00
2013-09-16 02:15:34 +00:00
----------------------------------------------------------------
-- Dependent packages
removeMe :: FilePath -> [PackageBaseName] -> [PackageBaseName]
2013-03-03 06:47:03 +00:00
removeMe cabalfile = filter (/= me)
where
me = dropExtension $ takeFileName cabalfile
removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]
2013-09-11 05:09:18 +00:00
removeThem badpkgs = filter (`notElem` badpkgs)
problematicPackages :: [PackageBaseName]
2013-09-11 05:09:18 +00:00
problematicPackages = [
"base-compat" -- providing "Prelude"
]
attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]
attachPackageIds pkgs = map attachId
where
attachId x = case lookup x pkgs of
Nothing -> (x, Nothing)
Just p -> (x, p)
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
Left deps -> throwIO $ userError $ show deps ++ " are not installed"
Right (pd,_) -> if nullPkg pd
then throwIO $ userError $ file ++ " is broken"
else return pd
where
toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []
nullPkg pd = name == ""
where
2014-03-27 06:17:58 +00:00
PackageName name = 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]
cabalAllBuildInfo pd = libBI ++ execBI ++ testBI
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
----------------------------------------------------------------
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
Nothing -> 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