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

194 lines
7.4 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
, cabalConfigDependencies
) where
import Language.Haskell.GhcMod.CabalConfig
import Language.Haskell.GhcMod.Error
2014-08-12 16:11:32 +00:00
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
toModuleString)
2014-07-15 03:29:27 +00:00
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Types
import MonadUtils (liftIO)
import Control.Applicative ((<$>))
2014-05-08 01:49:40 +00:00
import qualified Control.Exception as E
2014-05-09 18:38:35 +00:00
import Control.Monad (filterM)
import Data.Maybe (maybeToList)
import Data.Set (fromList, toList)
import Distribution.Package (Dependency(Dependency)
2014-05-09 18:38:35 +00:00
, PackageName(PackageName))
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.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 :: (IOish m, MonadError GhcModError m)
=> [GHCOption]
-> Cradle
-> PackageDescription
-> m CompilerOptions
2013-09-19 07:21:48 +00:00
getCompilerOptions ghcopts cradle pkgDesc = do
gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
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
----------------------------------------------------------------
-- | Parse a cabal file and return a 'PackageDescription'.
parseCabalFile :: (IOish m, MonadError GhcModError m)
=> Cradle
-> FilePath
2014-08-12 16:11:32 +00:00
-> m PackageDescription
parseCabalFile cradle file = do
2014-08-14 02:11:02 +00:00
cid <- liftIO getGHCId
2014-08-12 16:11:32 +00:00
epgd <- liftIO $ readPackageDescription silent file
flags <- cabalConfigFlags cradle
case toPkgDesc cid flags epgd of
Left deps -> fail $ show deps ++ " are not installed"
Right (pd,_) -> if nullPkg pd
then fail $ file ++ " is broken"
else return pd
where
toPkgDesc cid flags =
finalizePackageDescription flags (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
2014-07-15 03:29:27 +00:00
benchBI = benchmarkBuildInfo 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
2014-09-05 15:58:12 +00:00
-- TODO: MonadError it up
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-07-15 03:29:27 +00:00
benchTargets = benchmarkTargets pd
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