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

218 lines
7.9 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 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))
import Distribution.PackageDescription
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)
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.Types
import System.Directory (doesFileExist)
2013-03-03 06:47:03 +00:00
import System.FilePath
----------------------------------------------------------------
2013-09-20 01:30:51 +00:00
-- | Getting necessary 'CompilerOptions' from three information sources.
2013-09-19 07:21:48 +00:00
getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc = do
gopts <- getGHCOptions ghcopts cradle cdir $ head buildInfos
2013-09-19 06:58:50 +00:00
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
2013-03-04 01:39:39 +00:00
Just cdir = cradleCabalDir cradle
Just cfile = cradleCabalFile cradle
pkgs = cradlePackages cradle
2013-09-19 07:21:48 +00:00
buildInfos = cabalAllBuildInfo pkgDesc
2013-09-16 00:56:08 +00:00
idirs = includeDirectories cdir wdir $ cabalSourceDirs buildInfos
depPkgs = attachPackageIds pkgs $ removeThem problematicPackages $ removeMe cfile $ 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
PackageName name = pkgName (package pd)
----------------------------------------------------------------
getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
getGHCOptions ghcopts cradle cdir binfo = do
cabalCpp <- cabalCppOptions cdir
let cpps = map ("-optP" ++) $ cppOptions binfo ++ cabalCpp
return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
2013-03-05 01:21:55 +00:00
where
pkgDb = cradlePackageDbOpts cradle
2013-03-05 01:21:55 +00:00
lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo
libDirs = map ("-L" ++) $ extraLibDirs binfo
2013-09-16 02:15:34 +00:00
exts = map (("-X" ++) . display) $ usedExtensions binfo
libs = map ("-l" ++) $ extraLibs binfo
cabalCppOptions :: FilePath -> IO [String]
cabalCppOptions dir = do
exist <- doesFileExist cabalMacro
if exist then
return ["-include", cabalMacro]
else
return []
where
cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"
2013-03-05 01:21:55 +00:00
----------------------------------------------------------------
2013-09-16 00:56:08 +00:00
-- | Extracting all 'BuildInfo' for libraries, executables, tests and benchmarks.
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
where
libBI = map libBuildInfo $ maybeToList $ library pd
execBI = map buildInfo $ executables pd
testBI = map testBuildInfo $ testSuites pd
2014-01-08 13:16:10 +00:00
#if __GLASGOW_HASKELL__ >= 704
benchBI = map benchmarkBuildInfo $ benchmarks pd
2014-01-08 13:16:10 +00:00
#else
benchBI = []
#endif
----------------------------------------------------------------
2013-09-16 00:56:08 +00:00
-- | Extracting package names of dependency.
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
2013-09-16 00:56:08 +00:00
cabalDependPackages bis = uniqueAndSort $ pkgs
where
pkgs = map getDependencyPackageName $ concatMap 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]
cabalSourceDirs bis = uniqueAndSort $ concatMap hsSourceDirs bis
----------------------------------------------------------------
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"
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
2013-09-21 15:26:55 +00:00
exeTargets <- mapM getExecutableTarget $ executables pd
testTargets <- mapM getTestTarget $ testSuites pd
return (libTargets,concat exeTargets,concat testTargets,benchTargets)
where
lib = case library pd of
Nothing -> []
Just l -> libModules l
libTargets = map toModuleString $ lib
2014-01-08 13:16:10 +00:00
#if __GLASGOW_HASKELL__ >= 704
benchTargets = map toModuleString $ concatMap benchmarkModules $ 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 =
case testInterface ts of
(TestSuiteExeV10 _ filePath) -> do
let maybeTests = [p </> e | p <- hsSourceDirs $ testBuildInfo ts, e <- [filePath]]
liftIO $ filterM doesFileExist maybeTests
(TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]
(TestSuiteUnsupported _) -> return []
getExecutableTarget :: Executable -> IO [String]
getExecutableTarget exe = do
let maybeExes = [p </> e | p <- hsSourceDirs $ buildInfo exe, e <- [modulePath exe]]
liftIO $ filterM doesFileExist maybeExes