module Distribution.Simple.GHC (
configure, getInstalledPackages,
buildLib, buildExe,
installLib, installExe,
libAbiHash,
registerPackage,
ghcOptions,
ghcVerbosityOptions,
ghcPackageDbOptions,
ghcLibDir,
) where
import qualified Distribution.Simple.GHC.IPI641 as IPI641
import qualified Distribution.Simple.GHC.IPI642 as IPI642
import Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(..), Executable(..)
, Library(..), libModules, hcOptions, usedExtensions, allExtensions )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(..) )
import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
, absoluteInstallDirs )
import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Package
( PackageIdentifier, Package(..), PackageName(..) )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg
, ProgramLocation(..), rawSystemProgram, rawSystemProgramConf
, rawSystemProgramStdout, rawSystemProgramStdoutConf
, requireProgramVersion, requireProgram, getProgramOutput
, userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
, ghcProgram, ghcPkgProgram, hsc2hsProgram
, arProgram, ranlibProgram, ldProgram
, gccProgram, stripProgram )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar as Ar
import qualified Distribution.Simple.Program.Ld as Ld
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
, OptimisationLevel(..), PackageDB(..), PackageDBStack
, Flag, languageToFlags, extensionsToFlags )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
import Distribution.System
( OS(..), buildOS )
import Distribution.Verbosity
import Distribution.Text
( display, simpleParse )
import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))
import Control.Monad ( unless, when, liftM )
import Data.Char ( isSpace )
import Data.List
import Data.Maybe ( catMaybes )
import Data.Monoid ( Monoid(..) )
import System.Directory
( removeFile, getDirectoryContents, doesFileExist
, getTemporaryDirectory )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension, splitExtension )
import System.IO (hClose, hPutStrLn)
import Distribution.Compat.Exception (catchExit, catchIO)
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
-> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)
configure verbosity hcPath hcPkgPath conf0 = do
(ghcProg, ghcVersion, conf1) <-
requireProgramVersion verbosity ghcProgram
(orLaterVersion (Version [6,4] []))
(userMaybeSpecifyPath "ghc" hcPath conf0)
(ghcPkgProg, ghcPkgVersion, conf2) <-
requireProgramVersion verbosity ghcPkgProgram {
programFindLocation = guessGhcPkgFromGhcPath ghcProg
}
anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1)
when (ghcVersion /= ghcPkgVersion) $ die $
"Version mismatch between ghc and ghc-pkg: "
++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "
++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion
let hsc2hsProgram' = hsc2hsProgram {
programFindLocation = guessHsc2hsFromGhcPath ghcProg
}
conf3 = addKnownProgram hsc2hsProgram' conf2
languages <- getLanguages verbosity ghcProg
extensions <- getExtensions verbosity ghcProg
ghcInfo <- if ghcVersion >= Version [6,7] []
then do xs <- getProgramOutput verbosity ghcProg ["--info"]
case reads xs of
[(i, ss)]
| all isSpace ss ->
return i
_ ->
die "Can't parse --info output of GHC"
else return []
let comp = Compiler {
compilerId = CompilerId GHC ghcVersion,
compilerLanguages = languages,
compilerExtensions = extensions
}
conf4 = configureToolchain ghcProg ghcInfo conf3
return (comp, conf4)
guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity
-> IO (Maybe FilePath)
guessToolFromGhcPath tool ghcProg verbosity
= do let path = programPath ghcProg
dir = takeDirectory path
versionSuffix = takeVersionSuffix (dropExeExtension path)
guessNormal = dir </> tool <.> exeExtension
guessGhcVersioned = dir </> (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension
guessVersioned = dir </> (tool ++ versionSuffix) <.> exeExtension
guesses | null versionSuffix = [guessNormal]
| otherwise = [guessGhcVersioned,
guessVersioned,
guessNormal]
info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir
exists <- mapM doesFileExist guesses
case [ file | (file, True) <- zip guesses exists ] of
[] -> return Nothing
(fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp
return (Just fp)
where takeVersionSuffix :: FilePath -> String
takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse
dropExeExtension :: FilePath -> FilePath
dropExeExtension filepath =
case splitExtension filepath of
(filepath', extension) | extension == exeExtension -> filepath'
| otherwise -> filepath
guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)
guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"
guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)
guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"
configureToolchain :: ConfiguredProgram -> [(String, String)]
-> ProgramConfiguration
-> ProgramConfiguration
configureToolchain ghcProg ghcInfo =
addKnownProgram gccProgram {
programFindLocation = findProg gccProgram
[ if ghcVersion >= Version [6,12] []
then mingwBinDir </> "gcc.exe"
else baseDir </> "gcc.exe" ],
programPostConf = configureGcc
}
. addKnownProgram ldProgram {
programFindLocation = findProg ldProgram
[ if ghcVersion >= Version [6,12] []
then mingwBinDir </> "ld.exe"
else libDir </> "ld.exe" ],
programPostConf = configureLd
}
. addKnownProgram arProgram {
programFindLocation = findProg arProgram
[ if ghcVersion >= Version [6,12] []
then mingwBinDir </> "ar.exe"
else libDir </> "ar.exe" ]
}
where
Just ghcVersion = programVersion ghcProg
compilerDir = takeDirectory (programPath ghcProg)
baseDir = takeDirectory compilerDir
mingwBinDir = baseDir </> "mingw" </> "bin"
libDir = baseDir </> "gcc-lib"
includeDir = baseDir </> "include" </> "mingw"
isWindows = case buildOS of Windows -> True; _ -> False
findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)
findProg prog locations
| isWindows = \verbosity -> look locations verbosity
| otherwise = programFindLocation prog
where
look [] verbosity = do
warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")
programFindLocation prog verbosity
look (f:fs) verbosity = do
exists <- doesFileExist f
if exists then return (Just f)
else look fs verbosity
ccFlags = getFlags "C compiler flags"
gccLinkerFlags = getFlags "Gcc Linker flags"
ldLinkerFlags = getFlags "Ld Linker flags"
getFlags key = case lookup key ghcInfo of
Nothing -> []
Just flags ->
case reads flags of
[(args, "")] -> args
_ -> []
configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags))
$ configureGcc' v cp
configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureGcc'
| isWindows = \_ gccProg -> case programLocation gccProg of
FoundOnSystem {}
| ghcVersion < Version [6,11] [] ->
return ["-B" ++ libDir, "-I" ++ includeDir]
_ -> return []
| otherwise = \_ _ -> return []
configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp
configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureLd' verbosity ldProg = do
tempDir <- getTemporaryDirectory
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
withTempFile tempDir ".o" $ \testofile testohnd -> do
hPutStrLn testchnd "int foo() {}"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
withTempFile tempDir ".o" $ \testofile' testohnd' ->
do
hClose testohnd'
_ <- rawSystemProgramStdout verbosity ldProg
["-x", "-r", testofile, "-o", testofile']
return True
`catchIO` (\_ -> return False)
`catchExit` (\_ -> return False)
if ldx
then return ["-x"]
else return []
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]
getLanguages _ ghcProg
| ghcVersion >= Version [7] [] = return [(Haskell98, "-XHaskell98")
,(Haskell2010, "-XHaskell2010")]
| otherwise = return [(Haskell98, "")]
where
Just ghcVersion = programVersion ghcProg
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]
getExtensions verbosity ghcProg
| ghcVersion >= Version [6,7] [] = do
str <- rawSystemStdout verbosity (programPath ghcProg)
["--supported-languages"]
let extStrs = if ghcVersion >= Version [7] []
then lines str
else
[ extStr''
| extStr <- lines str
, let extStr' = case extStr of
'N' : 'o' : xs -> xs
_ -> "No" ++ extStr
, extStr'' <- [extStr, extStr']
]
let extensions0 = [ (ext, "-X" ++ display ext)
| Just ext <- map simpleParse extStrs ]
extensions1 = if ghcVersion >= Version [6,8] [] &&
ghcVersion < Version [6,10] []
then
(EnableExtension NamedFieldPuns, "-XRecordPuns") :
(DisableExtension NamedFieldPuns, "-XNoRecordPuns") :
extensions0
else extensions0
extensions2 = if ghcVersion < Version [7,1] []
then
(EnableExtension NondecreasingIndentation, "") :
(DisableExtension NondecreasingIndentation, "") :
extensions1
else extensions1
return extensions2
| otherwise = return oldLanguageExtensions
where
Just ghcVersion = programVersion ghcProg
oldLanguageExtensions :: [(Extension, Flag)]
oldLanguageExtensions =
let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
(DisableExtension f, disable)]
fglasgowExts = ("-fglasgow-exts",
"")
fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)
in concatMap doFlag
[(OverlappingInstances , fFlag "allow-overlapping-instances")
,(TypeSynonymInstances , fglasgowExts)
,(TemplateHaskell , fFlag "th")
,(ForeignFunctionInterface , fFlag "ffi")
,(MonomorphismRestriction , fFlag "monomorphism-restriction")
,(MonoPatBinds , fFlag "mono-pat-binds")
,(UndecidableInstances , fFlag "allow-undecidable-instances")
,(IncoherentInstances , fFlag "allow-incoherent-instances")
,(Arrows , fFlag "arrows")
,(Generics , fFlag "generics")
,(ImplicitPrelude , fFlag "implicit-prelude")
,(ImplicitParams , fFlag "implicit-params")
,(CPP , ("-cpp", ""))
,(BangPatterns , fFlag "bang-patterns")
,(KindSignatures , fglasgowExts)
,(RecursiveDo , fglasgowExts)
,(ParallelListComp , fglasgowExts)
,(MultiParamTypeClasses , fglasgowExts)
,(FunctionalDependencies , fglasgowExts)
,(Rank2Types , fglasgowExts)
,(RankNTypes , fglasgowExts)
,(PolymorphicComponents , fglasgowExts)
,(ExistentialQuantification , fglasgowExts)
,(ScopedTypeVariables , fFlag "scoped-type-variables")
,(FlexibleContexts , fglasgowExts)
,(FlexibleInstances , fglasgowExts)
,(EmptyDataDecls , fglasgowExts)
,(PatternGuards , fglasgowExts)
,(GeneralizedNewtypeDeriving , fglasgowExts)
,(MagicHash , fglasgowExts)
,(UnicodeSyntax , fglasgowExts)
,(PatternSignatures , fglasgowExts)
,(UnliftedFFITypes , fglasgowExts)
,(LiberalTypeSynonyms , fglasgowExts)
,(TypeOperators , fglasgowExts)
,(GADTs , fglasgowExts)
,(RelaxedPolyRec , fglasgowExts)
,(ExtendedDefaultRules , fFlag "extended-default-rules")
,(UnboxedTuples , fglasgowExts)
,(DeriveDataTypeable , fglasgowExts)
,(ConstrainedClassMethods , fglasgowExts)
]
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO PackageIndex
getInstalledPackages verbosity packagedbs conf = do
checkPackageDbStack packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs conf
topDir <- ghcLibDir' verbosity ghcProg
let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
| (_, pkgs) <- pkgss ]
return $! hackRtsPackage (mconcat indexes)
where
Just ghcProg = lookupProgram ghcProgram conf
hackRtsPackage index =
case PackageIndex.lookupPackageName index (PackageName "rts") of
[(_,[rts])]
-> PackageIndex.insert (removeMingwIncludeDir rts) index
_ -> index
ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
ghcLibDir verbosity lbi =
(reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]
ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
ghcLibDir' verbosity ghcProg =
(reverse . dropWhile isSpace . reverse) `fmap`
rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]
checkPackageDbStack :: PackageDBStack -> IO ()
checkPackageDbStack (GlobalPackageDB:rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack _ =
die $ "GHC.getInstalledPackages: the global package db must be "
++ "specified first and cannot be specified multiple times"
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir pkg =
let ids = InstalledPackageInfo.includeDirs pkg
ids' = filter (not . ("mingw" `isSuffixOf`)) ids
in pkg { InstalledPackageInfo.includeDirs = ids' }
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs conf
| ghcVersion >= Version [6,9] [] =
sequence
[ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb
return (packagedb, pkgs)
| packagedb <- packagedbs ]
where
Just ghcPkgProg = lookupProgram ghcPkgProgram conf
Just ghcProg = lookupProgram ghcProgram conf
Just ghcVersion = programVersion ghcProg
getInstalledPackages' verbosity packagedbs conf = do
str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]
let pkgFiles = [ init line | line <- lines str, last line == ':' ]
dbFile packagedb = case (packagedb, pkgFiles) of
(GlobalPackageDB, global:_) -> return $ Just global
(UserPackageDB, _global:user:_) -> return $ Just user
(UserPackageDB, _global:_) -> return $ Nothing
(SpecificPackageDB specific, _) -> return $ Just specific
_ -> die "cannot read ghc-pkg package listing"
pkgFiles' <- mapM dbFile packagedbs
sequence [ withFileContents file $ \content -> do
pkgs <- readPackages file content
return (db, pkgs)
| (db , Just file) <- zip packagedbs pkgFiles' ]
where
readPackages
| ghcVersion >= Version [6,4,2] []
= \file content -> case reads content of
[(pkgs, _)] -> return (map IPI642.toCurrent pkgs)
_ -> failToRead file
| otherwise
= \file content -> case reads content of
[(pkgs, _)] -> return (map IPI641.toCurrent pkgs)
_ -> failToRead file
Just ghcProg = lookupProgram ghcProgram conf
Just ghcVersion = programVersion ghcProg
failToRead file = die $ "cannot read ghc package database " ++ file
substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
substTopDir topDir ipo
= ipo {
InstalledPackageInfo.importDirs
= map f (InstalledPackageInfo.importDirs ipo),
InstalledPackageInfo.libraryDirs
= map f (InstalledPackageInfo.libraryDirs ipo),
InstalledPackageInfo.includeDirs
= map f (InstalledPackageInfo.includeDirs ipo),
InstalledPackageInfo.frameworkDirs
= map f (InstalledPackageInfo.frameworkDirs ipo),
InstalledPackageInfo.haddockInterfaces
= map f (InstalledPackageInfo.haddockInterfaces ipo),
InstalledPackageInfo.haddockHTMLs
= map f (InstalledPackageInfo.haddockHTMLs ipo)
}
where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
f x = x
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity pkg_descr lbi lib clbi = do
let pref = buildDir lbi
pkgid = packageId pkg_descr
runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)
ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)
ifProfLib = when (withProfLib lbi)
ifSharedLib = when (withSharedLib lbi)
ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)
comp = compiler lbi
ghcVersion = compilerVersion comp
libBi <- hackThreadedFlag verbosity
comp (withProfLib lbi) (libBuildInfo lib)
let libTargetDir = pref
forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi
createDirectoryIfMissingVerbose verbosity True libTargetDir
let ghcArgs =
"--make"
: ["-package-name", display pkgid ]
++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity
++ map display (libModules lib)
ghcArgsProf = ghcArgs
++ ["-prof",
"-hisuf", "p_hi",
"-osuf", "p_o"
]
++ ghcProfOptions libBi
ghcArgsShared = ghcArgs
++ ["-dynamic",
"-hisuf", "dyn_hi",
"-osuf", "dyn_o", "-fPIC"
]
++ ghcSharedOptions libBi
unless (null (libModules lib)) $
do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)
ifProfLib (runGhcProg ghcArgsProf)
ifSharedLib (runGhcProg ghcArgsShared)
unless (null (cSources libBi)) $ do
info verbosity "Building C Sources..."
sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref
filename verbosity
False
(withProfLib lbi)
createDirectoryIfMissingVerbose verbosity True odir
runGhcProg args
ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"]))
| filename <- cSources libBi]
info verbosity "Linking..."
let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)
vanillaLibFilePath = libTargetDir </> mkLibName pkgid
profileLibFilePath = libTargetDir </> mkProfLibName pkgid
sharedLibFilePath = libTargetDir </> mkSharedLibName pkgid
(compilerId (compiler lbi))
ghciLibFilePath = libTargetDir </> mkGHCiLibName pkgid
libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest
sharedLibInstallPath = libInstallPath </> mkSharedLibName pkgid
(compilerId (compiler lbi))
stubObjs <- fmap catMaybes $ sequence
[ findFileWithExtension [objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] []
, x <- libModules lib ]
stubProfObjs <- fmap catMaybes $ sequence
[ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] []
, x <- libModules lib ]
stubSharedObjs <- fmap catMaybes $ sequence
[ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
(ModuleName.toFilePath x ++"_stub")
| ghcVersion < Version [7,2] []
, x <- libModules lib ]
hObjs <- getHaskellObjects lib lbi
pref objExtension True
hProfObjs <-
if (withProfLib lbi)
then getHaskellObjects lib lbi
pref ("p_" ++ objExtension) True
else return []
hSharedObjs <-
if (withSharedLib lbi)
then getHaskellObjects lib lbi
pref ("dyn_" ++ objExtension) False
else return []
unless (null hObjs && null cObjs && null stubObjs) $ do
sequence_
[ removeFile libFilePath `catchIO` \_ -> return ()
| libFilePath <- [vanillaLibFilePath, profileLibFilePath
,sharedLibFilePath, ghciLibFilePath] ]
let staticObjectFiles =
hObjs
++ map (pref </>) cObjs
++ stubObjs
profObjectFiles =
hProfObjs
++ map (pref </>) cObjs
++ stubProfObjs
ghciObjFiles =
hObjs
++ map (pref </>) cObjs
++ stubObjs
dynamicObjectFiles =
hSharedObjs
++ map (pref </>) cSharedObjs
++ stubSharedObjs
ghcSharedLinkArgs =
[ "-no-auto-link-packages",
"-shared",
"-dynamic",
"-o", sharedLibFilePath ]
++ (if buildOS == OSX
then ["-dylib-install-name", sharedLibInstallPath]
else [])
++ dynamicObjectFiles
++ ["-package-name", display pkgid ]
++ ghcPackageFlags lbi clbi
++ ["-l"++extraLib | extraLib <- extraLibs libBi]
++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]
ifVanillaLib False $ do
(arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)
Ar.createArLibArchive verbosity arProg
vanillaLibFilePath staticObjectFiles
ifProfLib $ do
(arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)
Ar.createArLibArchive verbosity arProg
profileLibFilePath profObjectFiles
ifGHCiLib $ do
(ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
Ld.combineObjectFiles verbosity ldProg
ghciLibFilePath ghciObjFiles
ifSharedLib $
runGhcProg ghcSharedLinkArgs
buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity _pkg_descr lbi
exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
let pref = buildDir lbi
runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)
exeBi <- hackThreadedFlag verbosity
(compiler lbi) (withProfExe lbi) (buildInfo exe)
let exeNameReal = exeName' <.>
(if null $ takeExtension exeName' then exeExtension else "")
let targetDir = pref </> exeName'
let exeDir = targetDir </> (exeName' ++ "-tmp")
createDirectoryIfMissingVerbose verbosity True targetDir
createDirectoryIfMissingVerbose verbosity True exeDir
unless (null (cSources exeBi)) $ do
info verbosity "Building C Sources."
sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi
exeDir filename verbosity
(withDynExe lbi) (withProfExe lbi)
createDirectoryIfMissingVerbose verbosity True odir
runGhcProg args
| filename <- cSources exeBi]
srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)
let binArgs linkExe dynExe profExe =
"--make"
: (if linkExe
then ["-o", targetDir </> exeNameReal]
else ["-c"])
++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity
++ [exeDir </> x | x <- cObjs]
++ [srcMainFile]
++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]
++ ["-l"++lib | lib <- extraLibs exeBi]
++ ["-L"++libDir | libDir <- extraLibDirs exeBi]
++ concat [["-framework", f] | f <- PD.frameworks exeBi]
++ if dynExe
then ["-dynamic"]
else []
++ if profExe
then ["-prof",
"-hisuf", "p_hi",
"-osuf", "p_o"
] ++ ghcProfOptions exeBi
else []
when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)
(runGhcProg (binArgs False (withDynExe lbi) False))
runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi))
hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo
hackThreadedFlag verbosity comp prof bi
| not mustFilterThreaded = return bi
| otherwise = do
warn verbosity $ "The ghc flag '-threaded' is not compatible with "
++ "profiling in ghc-6.8 and older. It will be disabled."
return bi { options = filterHcOptions (/= "-threaded") (options bi) }
where
mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] []
&& "-threaded" `elem` hcOptions GHC bi
filterHcOptions p hcoptss =
[ (hc, if hc == GHC then filter p opts else opts)
| (hc, opts) <- hcoptss ]
getHaskellObjects :: Library -> LocalBuildInfo
-> FilePath -> String -> Bool -> IO [FilePath]
getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
let splitSuffix = if compilerVersion (compiler lbi) <
Version [6, 11] []
then "_split"
else "_" ++ wanted_obj_ext ++ "_split"
dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
| x <- libModules lib ]
objss <- mapM getDirectoryContents dirs
let objs = [ dir </> obj
| (objs',dir) <- zip objss dirs, obj <- objs',
let obj_ext = takeExtension obj,
'.':wanted_obj_ext == obj_ext ]
return objs
| otherwise =
return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
| x <- libModules lib ]
libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO String
libAbiHash verbosity pkg_descr lbi lib clbi = do
libBi <- hackThreadedFlag verbosity
(compiler lbi) (withProfLib lbi) (libBuildInfo lib)
let
ghcArgs =
"--abi-hash"
: ["-package-name", display (packageId pkg_descr) ]
++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity
++ map display (exposedModules lib)
rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs
constructGHCCmdLine
:: LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> Verbosity
-> [String]
constructGHCCmdLine lbi bi clbi odir verbosity =
ghcVerbosityOptions verbosity
++ ghcOptions lbi bi clbi odir
ghcVerbosityOptions :: Verbosity -> [String]
ghcVerbosityOptions verbosity
| verbosity >= deafening = ["-v"]
| verbosity >= normal = []
| otherwise = ["-w", "-v0"]
ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> [String]
ghcOptions lbi bi clbi odir
= ["-hide-all-packages"]
++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ]
++ ghcPackageDbOptions (withPackageDB lbi)
++ ["-split-objs" | splitObjs lbi ]
++ ["-i"]
++ ["-i" ++ odir]
++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
++ ["-i" ++ autogenModulesDir lbi]
++ ["-I" ++ autogenModulesDir lbi]
++ ["-I" ++ odir]
++ ["-I" ++ dir | dir <- PD.includeDirs bi]
++ ["-optP" ++ opt | opt <- cppOptions bi]
++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]
++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] []
, inc <- PD.includes bi ]
++ [ "-odir", odir, "-hidir", odir ]
++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ]
++ ghcPackageFlags lbi clbi
++ (case withOptimization lbi of
NoOptimisation -> []
NormalOptimisation -> ["-O"]
MaximumOptimisation -> ["-O2"])
++ hcOptions GHC bi
++ languageToFlags (compiler lbi) (defaultLanguage bi)
++ extensionsToFlags (compiler lbi) (usedExtensions bi)
where
ghcVer = compilerVersion (compiler lbi)
ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]
ghcPackageFlags lbi clbi
| ghcVer >= Version [6,11] []
= concat [ ["-package-id", display ipkgid]
| (ipkgid, _) <- componentPackageDeps clbi ]
| otherwise = concat [ ["-package", display pkgid]
| (_, pkgid) <- componentPackageDeps clbi ]
where
ghcVer = compilerVersion (compiler lbi)
ghcPackageDbOptions :: PackageDBStack -> [String]
ghcPackageDbOptions dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
(GlobalPackageDB:dbs) -> "-no-user-package-conf"
: concatMap specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = [ "-package-conf", db ]
specific _ = ierror
ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath -> Verbosity -> Bool -> Bool
->(FilePath,[String])
constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling
= let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref
| otherwise = pref </> takeDirectory filename
in
(odir,
ghcCcOptions lbi bi clbi odir
++ (if verbosity >= deafening then ["-v"] else [])
++ ["-c",filename]
++ ["-dynamic" | dynamic]
++ ["-prof" | profiling])
ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> [String]
ghcCcOptions lbi bi clbi odir
= ["-I" ++ dir | dir <- odir : PD.includeDirs bi]
++ ghcPackageDbOptions (withPackageDB lbi)
++ ghcPackageFlags lbi clbi
++ ["-optc" ++ opt | opt <- PD.ccOptions bi]
++ (case withOptimization lbi of
NoOptimisation -> []
_ -> ["-optc-O2"])
++ ["-odir", odir]
mkGHCiLibName :: PackageIdentifier -> String
mkGHCiLibName lib = "HS" ++ display lib <.> "o"
installExe :: Verbosity
-> LocalBuildInfo
-> InstallDirs FilePath
-> FilePath
-> (FilePath, FilePath)
-> PackageDescription
-> Executable
-> IO ()
installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do
let binDir = bindir installDirs
createDirectoryIfMissingVerbose verbosity True binDir
let exeFileName = exeName exe <.> exeExtension
fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix
installBinary dest = do
installExecutableFile verbosity
(buildPref </> exeName exe </> exeFileName)
(dest <.> exeExtension)
stripExe verbosity lbi exeFileName (dest <.> exeExtension)
installBinary (binDir </> fixedExeBaseName)
stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()
stripExe verbosity lbi name path = when (stripExes lbi) $
case lookupProgram stripProgram (withPrograms lbi) of
Just strip -> rawSystemProgram verbosity strip args
Nothing -> unless (buildOS == Windows) $
warn verbosity $ "Unable to strip executable '" ++ name
++ "' (missing the 'strip' program)"
where
args = path : case buildOS of
OSX -> ["-x"]
_ -> []
installLib :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> FilePath
-> PackageDescription
-> Library
-> IO ()
installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do
let copyHelper installFun src dst n = do
createDirectoryIfMissingVerbose verbosity True dst
installFun verbosity (src </> n) (dst </> n)
copy = copyHelper installOrdinaryFile
copyShared = copyHelper installExecutableFile
copyModuleFiles ext =
findModuleFiles [builtDir] [ext] (libModules lib)
>>= installOrdinaryFiles verbosity targetDir
ifVanilla $ copyModuleFiles "hi"
ifProf $ copyModuleFiles "p_hi"
ifShared $ copyModuleFiles "dyn_hi"
ifVanilla $ copy builtDir targetDir vanillaLibName
ifProf $ copy builtDir targetDir profileLibName
ifGHCi $ copy builtDir targetDir ghciLibName
ifShared $ copyShared builtDir dynlibTargetDir sharedLibName
ifVanilla $ updateLibArchive verbosity lbi
(targetDir </> vanillaLibName)
ifProf $ updateLibArchive verbosity lbi
(targetDir </> profileLibName)
where
vanillaLibName = mkLibName pkgid
profileLibName = mkProfLibName pkgid
ghciLibName = mkGHCiLibName pkgid
sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi))
pkgid = packageId pkg
hasLib = not $ null (libModules lib)
&& null (cSources (libBuildInfo lib))
ifVanilla = when (hasLib && withVanillaLib lbi)
ifProf = when (hasLib && withProfLib lbi)
ifGHCi = when (hasLib && withGHCiLib lbi)
ifShared = when (hasLib && withSharedLib lbi)
updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
updateLibArchive verbosity lbi path
| buildOS == OSX = do
(ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)
rawSystemProgram verbosity ranlib [path]
| otherwise = return ()
registerPackage
:: Verbosity
-> InstalledPackageInfo
-> PackageDescription
-> LocalBuildInfo
-> Bool
-> PackageDBStack
-> IO ()
registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do
let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)