module Language.Haskell.GhcMod.CabalApi (
getCompilerOptions
, parseCabalFile
, cabalAllBuildInfo
, cabalDependPackages
, cabalSourceDirs
, cabalAllTargets
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>))
import Control.Exception (throwIO)
import Control.Monad (filterM)
import CoreMonad (liftIO)
import Data.Maybe (maybeToList, catMaybes)
import Data.Set (fromList, toList)
import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency)
, PackageName(PackageName))
import qualified Distribution.Package as C
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(..))
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion)
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, (</>))
getCompilerOptions :: [GHCOption]
-> Cradle
-> PackageDescription
-> IO CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc = do
gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)
return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
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
removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]
removeThem badpkgs = filter (`notElem` badpkgs)
problematicPackages :: [PackageBaseName]
problematicPackages = [
"base-compat"
]
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
cabalBuildDirs :: [FilePath]
cabalBuildDirs = ["dist/build", "dist/build/autogen"]
includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
where
extdirs = map expand $ dirs ++ cabalBuildDirs
expand "." = cdir
expand subdir = cdir </> subdir
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 = C.pkgName (P.package pd)
getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
getGHCOptions ghcopts cradle rdir binfo = do
cabalCpp <- cabalCppOptions rdir
let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
where
pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
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
cabalCppOptions :: FilePath -> IO [String]
cabalCppOptions dir = do
exist <- doesFileExist cabalMacro
return $ if exist then
["-include", cabalMacro]
else
[]
where
cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
where
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
benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd
#else
benchBI = []
#endif
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
cabalDependPackages bis = uniqueAndSort pkgs
where
pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis
getDependencyPackageName (Dependency (PackageName nm) _) = nm
cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis
uniqueAndSort :: [String] -> [String]
uniqueAndSort = toList . fromList
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
cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])
cabalAllTargets pd = do
exeTargets <- mapM getExecutableTarget $ P.executables pd
testTargets <- mapM getTestTarget $ P.testSuites pd
return (libTargets,concat exeTargets,concat testTargets,benchTargets)
where
lib = case P.library pd of
Nothing -> []
Just l -> P.libModules l
libTargets = map toModuleString lib
#if __GLASGOW_HASKELL__ >= 704
benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
#else
benchTargets = []
#endif
toModuleString :: ModuleName -> String
toModuleString mn = fromFilePath $ toFilePath mn
fromFilePath :: FilePath -> String
fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
getTestTarget :: TestSuite -> IO [String]
getTestTarget ts =
case P.testInterface ts of
(TestSuiteExeV10 _ filePath) -> do
let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.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 <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
liftIO $ filterM doesFileExist maybeExes